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