Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AGELUP1

AGELUP1.m

Go to the documentation of this file. 
  1. AGELUP1 ;IHS/ASDS/EFG - UPDATE ELIGIBILITY FROM CMS FILE (MAIN) ;  
  1.  ;;7.1;PATIENT REGISTRATION;**2**;JAN 31, 2007
  1.  ;
  1.  ;This is the start point, that's called from option
  1.  ;AG TM ELI UPLOAD, on the Eligibility menu (AG TM ELIGIBILITY).
  1.  ;
  1. TXT ;
  1.  ;;Before processing your eligibility file, please run 2 reports,
  1.  ;;one in PtReg, and one in TPB:
  1.  ;;  
  1.  ;;     PTRG -> THR -> AGSM   Summary of 3rd Party Resources
  1.  ;;     RPTP -> BRRP   Brief (single-line) Claim Listing
  1.  ;;  
  1.  ;;Run the same two reports after processing your eligibility file.
  1.  ;;These two before/after reports will provide the data for you to
  1.  ;;determine the effectiveness of processing these eligibility files.
  1.  ;;  
  1.  ;;You can still process the eligibility file, even if you haven't
  1.  ;;run the reports...
  1.  ;;###
  1.  ;
  1. START ;start
  1.  NEW AGZERO,AGONE,AGTWO,AGPARSE,AGTYPE,AGFPVL,AGTDA,AG,AG1,AG2
  1.  NEW AGFL,AGFILE,AGPATH,AGQUIT,AGRCNT,AGSTART,AGTHREE,AGDT
  1.  NEW AGACT,AGCNT,AGMDOB,AGMNBR,AGMSFX,AGRUN,AGAUTO,AGINSPT
  1.  NEW DIR
  1.  NEW AGMATCH,AGMCDST
  1.  KILL ^TMP($J,"AGELUP")
  1.  D HELP^XBHELP("TXT","AGELUP1")
  1.  Q:'$$DIR^XBDIR("E")
  1.  D FRMT^AGELUPUT
  1.  Q:'$D(AGTDA)!$D(DIRUT)
  1.  D INSPT^AGELUPUT
  1.  I $G(AGINSPT)<1 W !,"An INSURER is needed.  Sorry." Q
  1.  D OPEN
  1.  Q:$D(DIRUT)
  1.  ;I POP W !,"Could not open host file",! Q
  1.  I POP W !,"Could not open host file",! H 3 Q  ;AG*7.1*2
  1.  S X="IORVON;IORVOFF"
  1.  D ENDR^%ZISS,AUDS^AGELUPUT,FLOOP,AUDR^AGELUPUT,RUN1^AGELUPUT:'$D(DIRUT),KILL^%ZISS
  1.  KILL ^TMP($J,"AGELUP")
  1.  U IO(0)
  1.  W !!,"D O N E",!!
  1.  I $$DIR^XBDIR("E","Press RETURN")
  1.  Q
  1. OPEN ;open host file
  1.  NEW AGLIST
  1.  KILL AGFILE,DIR
  1.  S AGPATH=$P($G(^AGFAC(DUZ(2),2)),U,2)
  1.  I AGPATH="" S AGPATH=$S($P(^%ZOSF("OS"),U,1)["UNIX":"/usr/spool/uucppublic/",1:$P($G(^AUTTSITE(1,1)),U,1))
  1.  S AGPATH=$$DIR^XBDIR("F","Enter directory containing host file. You will be asked for the filename seperately.",AGPATH,"","","",1)
  1.  Q:$D(DIRUT)
  1.  S AGLIST="",AG=$S("MR"[AGTYPE:"r",AGTYPE="P":"p",1:"d")
  1.  I '$$LIST^%ZISH(AGPATH,"cms"_AG_$$LTR^AGELUP3(3)_"*",.AGLIST) D  I $G(AGFILE) S AGFILE=AGLIST(AGFILE)
  1.  . NEW AG
  1.  . S AG=0
  1.  . F  S AG=$O(AGLIST(AG)) Q:'AG  W !,$J(AG,3),". ",AGLIST(AG) S:(('(AG#5))!('$D(AGLIST(AG+1)))) AGFILE=$$DIR^XBDIR("NO^1:"_AG,"Process which file (or '^' to specify file)") Q:$G(AGFILE)  I $D(DIRUT) KILL AGFILE Q
  1.  .Q
  1.  I '$L($G(AGFILE)) S AGFILE=$$DIR^XBDIR("F","Enter name of file","","","","",2)
  1.  Q:$D(DIRUT)
  1.  I $E(AGFILE,$L(AGFILE)-2,$L(AGFILE))=".gz" S DIRUT=1 W:$$DIR^XBDIR("E","Would you mind gunzip'ing this file, first? :-(") "" Q
  1.  ;BEGIN NEW CODE. CHECK FOR FILE NAME MATCHING TEMPLATE CHOSEN AG*7.1*2 PER E-MAIL FROM ADRIAN
  1.  I ($P(AGZERO,U)[("cmsx*")&($E($$UPPER^AGUTILS(AGFILE),1,4)'="CMSX"))!($P(AGZERO,U)[("cmsr*")&($E($$UPPER^AGUTILS(AGFILE),1,4)'="CMSR")) D  Q:'Y
  1.  .W !,"You have chosen a file which may not be the correct"
  1.  .W !,"format for the Template chosen."
  1.  .K DIR S DIR("A")="DO YOU WISH TO CONTINUE?"
  1.  .S DIR(0)="Y"
  1.  .D ^DIR
  1.  .S:'Y DIRUT=1
  1.  ;END NEW CODE
  1.  D OPEN^%ZISH("AGELFILE",AGPATH,AGFILE,"R")
  1.  Q
  1. FLOOP ;read through file
  1.  KILL AGQUIT
  1.  U IO(0)
  1.  D WAIT^DICD
  1.  I $D(^AGELUPLG("C",AGFILE)) S AGCNT=$P(^AGELUPLG($O(^AGELUPLG("C",AGFILE,""),-1),0),U,4) I AGCNT G FLOOP1
  1.  W "Counting records in file..."
  1.  S AGCNT=0
  1.  U IO
  1.  F  D  Q:$$STATUS^%ZISH
  1.  . I '(AGCNT#1000) U IO(0) W $J(AGCNT,8) U IO
  1.  . R X:DTIME
  1.  . S AGCNT=AGCNT+1
  1.  .Q
  1. FLOOP1 ;
  1.  D CLOSE^%ZISH("AGELFILE")
  1.  U IO(0)
  1.  W !!,AGCNT," records found in file.",!
  1.  S AGSTART=$$DIR^XBDIR("N^1:"_AGCNT,"Start at Record",1)-1
  1.  W !
  1.  Q:$D(DIRUT)
  1.  D RUN^AGELUPUT
  1.  I '$D(AGRUN) D CLOSE^%ZISH("AGELFILE") Q
  1.  D OPEN^%ZISH("AGELFILE",AGPATH,AGFILE,"R")
  1.  S AGRCNT=0
  1.  I AGSTART>1 U IO(0) D WAIT^DICD W "Positioning to record ",AGSTART U IO F I=1:1:AGSTART R X:DTIME S AGRCNT=AGRCNT+1
  1.  F  D  Q:$G(AGQUIT)
  1.  . KILL AG
  1.  . U IO
  1.  . R X:DTIME
  1.  . I $$STATUS^%ZISH S AGQUIT=1 Q
  1.  . U IO(0)
  1.  . S AGRCNT=AGRCNT+1
  1.  . I '(AGRCNT#1000) W $J(AGRCNT,8)
  1.  . D @AGPARSE
  1.  . Q:'AG("DFN")
  1.  . I AGTYPE="M" S X=AG("FNBR") X $P(^DD(9000003,.03,0),U,5,99) Q:'$D(X)
  1.  . I AGTYPE="D" S X=AG("FNBR") X $P(^DD(9000004,.03,0),U,5,99) Q:'$D(X)  I AGAUTO="A" Q:'$$MATCH^AGELUPUT
  1.  . I AGTYPE="R" S X=AG("FNBR") X $P(^DD(9000005,.04,0),U,5,99) Q:'$D(X)
  1.  . I AGFPVL'="",AGFPVL'=AG("FPRO") Q
  1.  . S ^TMP($J,"AGELUP",AG("DFN"))=1
  1.  . S AG("FNM")=AG("FLNM")_","_AG("FFNM")
  1.  . S:AG("FMI")'="" AG("FNM")=AG("FNM")_" "_AG("FMI")
  1.  . S AGACT=$S(AGAUTO="A":"F",1:"")
  1.  . I AGTYPE="M" D M^AGELUP2(.AG) I AG("DFN") D:AGACT="F" FILE^AGELUP2(.AG) S:AGACT="Q"!($D(DIRUT)) AGQUIT=1
  1.  . I AGTYPE="D" D D^AGELUP4(.AG) I AG("DFN") D:AGACT="F" FILE^AGELUP4(.AG) S:AGACT="Q"!($D(DIRUT)) AGQUIT=1
  1.  . I AGTYPE="R" D R^AGELUP3(.AG) I AG("DFN") D:AGACT="F" FILE^AGELUP3(.AG) S:AGACT="Q"!($D(DIRUT)) AGQUIT=1
  1.  .Q
  1.  D CLOSE^%ZISH("AGELFILE")
  1.  Q
  1. F ;fixed length parse
  1.  S AG("FSSN")=$E(X,$P(AGONE,U,8),$P(AGONE,U,9))        ; SSN
  1.  D DFN
  1.  Q:'AG("DFN")
  1.  S AG("FSEX")=$E(X,$P(AGONE,U,12)) ;Sex
  1.  S AG("FMAL1")="" ;Mail Adrs Line 1
  1.  S AG("FMAL2")="" ;Mail Adrs Line 2
  1.  S AG("FMAC")="" ;Mail Adrs City
  1.  S AG("FMAST")="" ;Mail Adrs State
  1.  S AG("FMAZ")="" ;Mail Adrs Zip
  1.  S AG("FLNM")=$$STRIP($E(X,$P(AGONE,U,1),$P(AGONE,U,2))) ;Last Name
  1.  S AG("FFNM")=$$STRIP($E(X,$P(AGONE,U,3),$P(AGONE,U,4))) ;First Name
  1.  S AG("FMI")=$TR($E(X,$P(AGONE,U,5))," ")              ;Middle Initial
  1.  S AG("FNBR")=$E(X,$P(AGONE,U,6),$P(AGONE,U,7))        ;Policy #
  1.  S AG("FSFX")=$TR($E(X,$P(AGONE,U,10),$P(AGONE,U,11))," ") ;Policy # Suffix
  1.  S AG("FDOB")=$$DFMT($E(X,$P(AGTWO,U,1),$P(AGTWO,U,2)),$P(AGZERO,U,5)) ;DOB
  1.  S AG("FPRO")=$E(X,$P(AGTHREE,U,1),$P(AGTHREE,U,2)) ;Process Only
  1.  S AGCNT=0
  1.  F  S AGCNT=$O(^AGELUP(AGTDA,4,AGCNT)) Q:'AGCNT  D
  1.  . S AGND=^AGELUP(AGTDA,4,AGCNT,0),AGDT1=$E(X,$P(AGND,U,1),$P(AGND,U,2))
  1.  . Q:'+AGDT1
  1.  . S AGDT1=$$DFMT(AGDT1,$P(AGZERO,U,5)),AGCVT=$P(AGND,U,5),AG("DT",AGDT1,AGCVT)=AGDT1,AGDT2=$E(X,$P(AGND,U,3),$P(AGND,U,4))
  1.  . I +AGDT2 S AGDT2=$$DFMT(AGDT2,$P(AGZERO,U,5)),$P(AG("DT",AGDT1,AGCVT),U,2)=AGDT2
  1.  . S $P(AG("DT",AGDT1,AGCVT),U,3)=AGCVT
  1.  .Q
  1.  Q
  1. V ;variable length parse
  1.  S AG("FSSN")=$P(X,AGDEL,$P(AGONE,U,8))   ;SSN
  1.  D DFN
  1.  Q:'AG("DFN")
  1.  S AG("FLNM")=$P(X,AGDEL,$P(AGONE,U,1))   ;Last Name
  1.  S AG("FFNM")=$P(X,AGDEL,$P(AGONE,U,3))   ;First Name
  1.  S AG("FMI")=$P(X,AGDEL,$P(AGONE,U,5))    ;Middle Initial
  1.  S AG("FNBR")=$P(X,AGDEL,$P(AGONE,U,6))   ;Policy #
  1.  S AG("FSFX")=$P(X,AGDEL,$P(AGONE,U,10))  ;Policy # Suffix
  1.  S AG("FDOB")=$$DFMT($E(X,AGDEL,$P(AGTWO,U,1)),$P(AGZERO,U,5)) ;DOB
  1.  S AG("FPRO")=$E(X,AGDEL,$P(AGTHREE,U,1)) ;Process Only
  1.  S AG("FSEX")=$P(X,AGDEL,$P(AGONE,U,12)) ;Sex
  1.  S AG("FMAL1")=$P(X,AGDEL,$P(AGSEVEN,U,1)) ;Mail Adrs Line 1
  1.  S AG("FMAL2")=$P(X,AGDEL,$P(AGSEVEN,U,3)) ;Mail Adrs Line 2
  1.  S AG("FMAC")=$P(X,AGDEL,$P(AGSEVEN,U,5))  ;Mail Adrs City
  1.  S AG("FMAST")=$P(X,AGDEL,$P(AGSEVEN,U,7)) ;Mail Adrs State
  1.  S AG("FMAZ")=$P(X,AGDEL,$P(AGSEVEN,U,9))  ;Mail Adrs Zip
  1.  S AGCNT=0
  1.  F  S AGCNT=$O(^AGELUP(AGTDA,4,AGCNT)) Q:'AGCNT  D
  1.  . S AGND=^AGELUP(AGTDA,4,AGCNT,0),AGDT=$P(X,AGDEL,$P(AGND,U,1))
  1.  . Q:'+AGDT
  1.  . S AGCVT=$P(X,AGDEL,$P(AGND,U,5))
  1.  . S AGDT=$$DFMT(AGDT,$P(AGZERO,U,5)),AG("DT",AGDT,AGCVT)=AGDT,AGDT2=$P(X,AGDEL,$P(AGND,U,3))
  1.  . S:+AGDT2 $P(AG("DT",AGDT,AGCVT),U,2)=$$DFMT(AGDT2,$P(AGZERO,U,5))
  1.  . S $P(AG("DT",AGDT,AGCVT),U,3)=AGCVT
  1.  .Q
  1.  Q
  1. STRIP(Y) ;strip trailing blanks
  1.  NEW I
  1.  F I=$L(Y):-1:1 I $E(Y,I)'=" " S Y=$E(Y,1,I) Q
  1.  KILL AGQUIT
  1.  Q Y
  1. DFMT(A,B) ;Format date A according to B.
  1.  I '+A Q ""
  1.  I B=1 Q ($E(A,1,4)-1700)_$E(A,5,6)_$E(A,7,8)
  1.  I B=2 Q ($E(A,5,8)-1700)_$E(A,1,4)
  1.  I B=3 Q $S($E(A,5,6)>50:2,1:3)_$E(A,5,6)_$E(A,1,4)
  1.  I B=4 Q $S($E(A,1,2)>50:2,1:3)_$E(A,1,2)_$E(A,3,6)
  1.  I B=5 D  Q A
  1.  . S A=$P(A," ",1)
  1.  . F %=1,2 S $P(A,"/",%)="0"_$P(A,"/",%)
  1.  . S A=($P(A,"/",3)-1700)_($E($P(A,"/",1),$L($P(A,"/",1))-1,$L($P(A,"/",1))))_($E($P(A,"/",2),$L($P(A,"/",2))-1,$L($P(A,"/",2))))
  1.  .Q
  1.  Q "????????"
  1. DFN ;Lookup Pt using SSN.
  1.  S AG("DFN")=0,AG("FSSN")=$TR(AG("FSSN"),"-/ ")
  1.  Q:'AG("FSSN")
  1.  S AG("DFN")=$O(^DPT("SSN",AG("FSSN"),0))
  1.  Q:'AG("DFN")
  1.  I $G(^TMP($J,"AGELUP",AG("DFN"))) S AG("DFN")=0
  1.  Q