AGELUP2 ;IHS/ASDS/EFG - PROCESS MCR ELIGIBILITY FROM CMS FILE ;
;;7.1;PATIENT REGISTRATION;**2**;JAN 31, 2007
;
M(AG) ;EP - process Medicare
KILL AG1,AG2,AGSAME
I $D(^AUPNMCR(AG("DFN"))) D MCRY I AGSAME S AGACT="S" Q
I AGAUTO'="A" D Q
. D HEAD^AGELUPUT("MEDICARE")
. I '$D(^AUPNMCR(AG("DFN"))) D MCRN
. D MDISP(5),PEND^AGELUPUT
.Q
U IO(0)
W "."
W:'(AGRCNT#100) $J(AGRCNT,8)
Q
MCRY ;if medicare coverage
S AGSAME=0
;MediCare name.
S (AGMNM,AG1(1))=$P($G(^AUPNMCR(AG("DFN"),21)),U)
;MediCare DOB.
S AGMDOB=$P($G(^AUPNMCR(AG("DFN"),21)),U,2)
S AG1(2)=AGMDOB
;MediCare #.
S (AGMNBR,AG1(3))=$P(^AUPNMCR(AG("DFN"),0),U,3)
;MediCare Suffix.
S AGMSFX=$P(^AUPNMCR(AG("DFN"),0),U,4)
S (AGMSFX,AG1(4))=$P($G(^AUTTMCS(+AGMSFX,0)),U)
;AG1("DT",EligDt,CovType)=EligDt^ELigEndDt^CovType
S DA=0
;F S DA=$O(^AUPNMCR(AG("DFN"),11,DA)) Q:'DA S %=^(DA,0) S:$P(%,U,3)="" $P(%,U,3)=" " S AG1("DT",$P(%,U,1),$P(%,U,3))=%
F S DA=$O(^AUPNMCR(AG("DFN"),11,DA)) Q:'DA D
.;S %=^(DA,0)
.S %=$P(^(DA,0),U,1,3) ;PART D COVERAGES THREW THIS OFF AG*7.1*2 IM????? NO IM FOUND DURING TESTING ON NEW HRN LENGTH
.Q:$P(%,U,3)="D" ;AG*7.1*2 IM22061 IGNORE PART D FOR DIFFERENCE COMPARISON
.S:$P(%,U,3)="" $P(%,U,3)=" "
.S AG1("DT",$P(%,U,1),$P(%,U,3))=%
KILL AGFL
D DFL
S:'$D(AGFL) AGSAME=1
Q
MCRN ;EP - No MCR/RRE coverage in rpms.
S AG1(1)="NO ELIGIBILITY ON FILE"
F I=2:1:4 S AG1(I)=""
D DFL
Q
DFL ;EP - Set descrepency flags.
KILL AGFL
S AG2(1)=$G(AG("FNM"))
S:AG2(1)'=$G(AGMNM) AGFL(1)=1 ;Name.
S AG2(2)=$G(AG("FDOB"))
S:AG2(2)'=$G(AGMDOB) AGFL(2)=1 ;DOB.
S AG2(3)=$G(AG("FNBR"))
S:AG2(3)'=$G(AGMNBR) AGFL(3)=1 ;#.
S AG2(4)=$G(AG("FSFX"))
S:AG2(4)'=$G(AGMSFX) AGFL(4)=1 ;Suffix.
;Compare file eligibilities with existing eligibilities.
;AG1("DT",EligDt,CovType)=EligDt^ELigEndDt^CovType
NEW I,J
S I=0
F S I=$O(AG("DT",I)) Q:'I D
. S J=0
. F S J=$O(AG("DT",I,J)) Q:J="" D
.. I $G(AG1("DT",I,J))'=AG("DT",I,J) S AGFL(5)=1
..Q
.Q
S I=0
F S I=$O(AG1("DT",I)) Q:'I D
. S J=0
. F S J=$O(AG1("DT",I,J)) Q:J="" D
.. I $G(AG("DT",I,J))'=AG1("DT",I,J) S AGFL(5)=1
..Q
.Q
Q
MDISP(AGDISP) ;EP - display medicare info
I AGDISP=5 S AG1(5)="DATES",AG2(5)=""
F I=1:1:AGDISP D
. W !,$P($T(@I),";;",$S(AGTYPE="D":3,1:2)),":",?13
. W:$G(AGFL(I)) $$S^AGVDF("RVN")
. W $S('$L(AG1(I)):" ",I=2:$$FMTE^XLFDT(AG1(I),5),1:AG1(I))
. W:$G(AGFL(I)) $$S^AGVDF("RVF")
. I AGTYPE="D",I=5 W " ( Matching Medicaid eligibility dates are not displayed )"
. W ?45,$S(I=2:$$FMTE^XLFDT(AG2(I),5),1:AG2(I))
.Q
I AGDISP=4 W !
;Dates from RPMS file.
S (AG1,AGCNT)=0
KILL AGLINE
F S AG1=$O(AG1("DT",AG1)) Q:'AG1 D
. S AGCVT=0
. F S AGCVT=$O(AG1("DT",AG1,AGCVT)) Q:AGCVT="" D
.. S AGCNT=AGCNT+1,AGLINE(AGCNT)=AG1("DT",AG1,AGCVT)
.. I $G(AG("DT",AG1,AGCVT)) S $P(AGLINE(AGCNT),"*",2)=AG("DT",AG1,AGCVT)
..Q
.Q
;Dates from incoming file.
S AG2=0
F S AG2=$O(AG("DT",AG2)) Q:'AG2 D
. S AGCVT=0
. F S AGCVT=$O(AG("DT",AG2,AGCVT)) Q:AGCVT="" D
.. Q:$G(AG1("DT",AG2,AGCVT)) S AGCNT=AGCNT+1,$P(AGLINE(AGCNT),"*",2)=AG("DT",AG2,AGCVT)
.. S:$P(AGLINE(AGCNT),"*",1)="" $P(AGLINE(AGCNT),"*",1)="^^"
..Q
.Q
S (I,AGCNT)=0
F S I=$O(AGLINE(I)) Q:'I D
. I AGTYPE="D" Q:$P(AGLINE(I),"*",2)="" Q:$P(AGLINE(I),"*",1)=$P(AGLINE(I),"*",2)
. S AGLINE(I)=$TR(AGLINE(I),"*","^")
. W !,"START DATE: "
. W ?13,$$FMTE^XLFDT($P(AGLINE(I),U,1),5)
. W ?45,$S('($P(AGLINE(I),U,1)):IORVON,1:""),$$FMTE^XLFDT($P(AGLINE(I),U,4),5),IORVOFF
. W !," END DATE: "
. W ?13,$$FMTE^XLFDT($P(AGLINE(I),U,2),5)
. W ?45,$S('$P(AGLINE(I),U,1):IORVON,($P(AGLINE(I),U,5))&($P(AGLINE(I),U,2)'=$P(AGLINE(I),U,5)):IORVON,1:""),$S($P(AGLINE(I),U,5):$$FMTE^XLFDT($P(AGLINE(I),U,5),5),1:$J("",10)),IORVOFF
. W !," COV TYPE: ",?13,$P(AGLINE(I),U,3),?45,$S('$L($P(AGLINE(I),U,3)):IORVON,1:""),$P(AGLINE(I),U,6),IORVOFF
.Q
Q
1 ;;MCR NAME;;MCD NAME;;
2 ;;MCR DOB;;MCD DOB;;
3 ;;MCR NUMBER;;MCD NUMBER;;
4 ;;SFX;;;;
5 ;;ELIGIBILITY;;ELIGIBILITY;;
;
FILE(AG) ;EP - file MEDICARE FIELDS
I '$D(^AUTTMCS("B",AG("FSFX"))) S DIC=9999999.32,DIC(0)="L",X=AG("FSFX") D ^DIC I +Y<1 W !,"Add to MEDICARE SUFFIX file failed for '",AG("FSFX"),"'.",$$DIR^XBDIR("E") Q
NEW AGADD
I '$D(^AUPNMCR(AG("DFN"),0)) D Q:+Y<0 S AGADD=1 I 1
. NEW DIC,DLAYGO,DD,DO
. S DIC="^AUPNMCR(",DIC(0)="F",DLAYGO=9000003,(DINUM,X)=AG("DFN")
. S DIC("DR")=".02////"_AGINSPT_";.03///"_AG("FNBR")_";.04///"_AG("FSFX")_";2101///"_AG("FNM")_";2102///"_AG("FDOB")
. K DD,DO
. D FILE^DICN,PTACT(1,AG("DFN")):+Y>0
.Q
E D S AGADD=0
. NEW DA,DIE,DR
. S DIE="^AUPNMCR(",DA=AG("DFN"),DR=""
. I $P(^AUPNMCR(DA,0),U,2)'=AGINSPT S DR=".02////"_AGINSPT
. I AG("FNBR")'="",AG("FNBR")'=$P(^AUPNMCR(DA,0),U,3) S DR=DR_$S($L(DR):";",1:"")_".03///"_AG("FNBR")
. I AG("FSFX")'="" D
.. I $P(^AUPNMCR(DA,0),U,4),AG("FSFX")=$P(^AUTTMCS($P(^AUPNMCR(DA,0),U,4),0),U) Q
.. S DR=DR_$S($L(DR):";",1:"")_".04///"_AG("FSFX")
..Q
. I AG("FNM")'="",AG("FNM")'=$P($G(^AUPNMCR(DA,21)),U) S DR=DR_$S($L(DR):";",1:"")_"2101///"_AG("FNM")
. I AG("FDOB")'="",AG("FDOB")'=$P($G(^AUPNMCR(DA,21)),U,2) S DR=DR_$S($L(DR):";",1:"")_"2102////"_AG("FDOB")
. I $L(DR) NEW DITC S DITC="" D ^DIE,PTACT(2,AG("DFN")):'$D(Y) KILL DITC
.Q
;
S DA(1)=AG("DFN"),DIK="^AUPNMCR("_DA(1)_",11,",DA=0
;F S DA=$O(^AUPNMCR(DA(1),11,DA)) Q:'DA D ^DIK
F S DA=$O(^AUPNMCR(DA(1),11,DA)) Q:'DA I $P($G(^AUPNMCR(DA(1),11,DA,0)),U,3)'="D" D ^DIK ;IHS/SD/TPF 4/25/2006 AG*7.1*2 IM20585
S DIC="^AUPNMCR("_DA(1)_",11,",DIC(0)="F",DIC("P")=$P(^DD(9000003,1101,0),U,2)
KILL DD,DO
S AGI=0
F S AGI=$O(AG("DT",AGI)) Q:'AGI D
. S AGJ=0
. F S AGJ=$O(AG("DT",AGI,AGJ)) Q:AGJ="" D
.. S X=$P(AG("DT",AGI,AGJ),U,1)
.. Q:'X
.. S DIC("DR")=".02////^S X=$P(AG(""DT"",AGI,AGJ),U,2)"
.. S DIC("DR")=DIC("DR")_";.03////^S X=$P(AG(""DT"",AGI,AGJ),U,3)"
.. K DD,DO
.. D FILE^DICN
.. Q:AGADD
.. D:+Y>0 PTACT(2,AG("DFN"))
..Q
.Q
KILL AGI,AGJ
;
D
. NEW DFN
. S DFN=AG("DFN")
. D ^AGDATCK
. I $D(AG("ER")) KILL AG("DATE"),AG("DTOT"),AG("ER") Q
. D UPDATE1^AGED(DUZ(2),AG("DFN"),4,"")
.Q
Q
;
PTACT(AG,X) ;EP - Record action AG on patient X (DFN). 1=add, 2=edit.
NEW DA,DIC,DIE,DINUM,DR,Y
S DA(1)=AGRUN,DIC("P")=$P(^DD(9009062.02,AG,0),U,2),DIC="^AGELUPLG("_DA(1)_","_AG_",",DIC(0)="F",DINUM=X
K DD,DO
D FILE^DICN
Q
AGELUP2 ;IHS/ASDS/EFG - PROCESS MCR ELIGIBILITY FROM CMS FILE ;
+1 ;;7.1;PATIENT REGISTRATION;**2**;JAN 31, 2007
+2 ;
M(AG) ;EP - process Medicare
+1 KILL AG1,AG2,AGSAME
+2 IF $DATA(^AUPNMCR(AG("DFN")))
DO MCRY
IF AGSAME
SET AGACT="S"
QUIT
+3 IF AGAUTO'="A"
Begin DoDot:1
+4 DO HEAD^AGELUPUT("MEDICARE")
+5 IF '$DATA(^AUPNMCR(AG("DFN")))
DO MCRN
+6 DO MDISP(5)
DO PEND^AGELUPUT
+7 QUIT
End DoDot:1
QUIT
+8 USE IO(0)
+9 WRITE "."
+10 IF '(AGRCNT#100)
WRITE $JUSTIFY(AGRCNT,8)
+11 QUIT
MCRY ;if medicare coverage
+1 SET AGSAME=0
+2 ;MediCare name.
+3 SET (AGMNM,AG1(1))=$PIECE($GET(^AUPNMCR(AG("DFN"),21)),U)
+4 ;MediCare DOB.
+5 SET AGMDOB=$PIECE($GET(^AUPNMCR(AG("DFN"),21)),U,2)
+6 SET AG1(2)=AGMDOB
+7 ;MediCare #.
+8 SET (AGMNBR,AG1(3))=$PIECE(^AUPNMCR(AG("DFN"),0),U,3)
+9 ;MediCare Suffix.
+10 SET AGMSFX=$PIECE(^AUPNMCR(AG("DFN"),0),U,4)
+11 SET (AGMSFX,AG1(4))=$PIECE($GET(^AUTTMCS(+AGMSFX,0)),U)
+12 ;AG1("DT",EligDt,CovType)=EligDt^ELigEndDt^CovType
+13 SET DA=0
+14 ;F S DA=$O(^AUPNMCR(AG("DFN"),11,DA)) Q:'DA S %=^(DA,0) S:$P(%,U,3)="" $P(%,U,3)=" " S AG1("DT",$P(%,U,1),$P(%,U,3))=%
+15 FOR
SET DA=$ORDER(^AUPNMCR(AG("DFN"),11,DA))
IF 'DA
QUIT
Begin DoDot:1
+16 ;S %=^(DA,0)
+17 ;PART D COVERAGES THREW THIS OFF AG*7.1*2 IM????? NO IM FOUND DURING TESTING ON NEW HRN LENGTH
SET %=$PIECE(^(DA,0),U,1,3)
+18 ;AG*7.1*2 IM22061 IGNORE PART D FOR DIFFERENCE COMPARISON
IF $PIECE(%,U,3)="D"
QUIT
+19 IF $PIECE(%,U,3)=""
SET $PIECE(%,U,3)=" "
+20 SET AG1("DT",$PIECE(%,U,1),$PIECE(%,U,3))=%
End DoDot:1
+21 KILL AGFL
+22 DO DFL
+23 IF '$DATA(AGFL)
SET AGSAME=1
+24 QUIT
MCRN ;EP - No MCR/RRE coverage in rpms.
+1 SET AG1(1)="NO ELIGIBILITY ON FILE"
+2 FOR I=2:1:4
SET AG1(I)=""
+3 DO DFL
+4 QUIT
DFL ;EP - Set descrepency flags.
+1 KILL AGFL
+2 SET AG2(1)=$GET(AG("FNM"))
+3 ;Name.
IF AG2(1)'=$GET(AGMNM)
SET AGFL(1)=1
+4 SET AG2(2)=$GET(AG("FDOB"))
+5 ;DOB.
IF AG2(2)'=$GET(AGMDOB)
SET AGFL(2)=1
+6 SET AG2(3)=$GET(AG("FNBR"))
+7 ;#.
IF AG2(3)'=$GET(AGMNBR)
SET AGFL(3)=1
+8 SET AG2(4)=$GET(AG("FSFX"))
+9 ;Suffix.
IF AG2(4)'=$GET(AGMSFX)
SET AGFL(4)=1
+10 ;Compare file eligibilities with existing eligibilities.
+11 ;AG1("DT",EligDt,CovType)=EligDt^ELigEndDt^CovType
+12 NEW I,J
+13 SET I=0
+14 FOR
SET I=$ORDER(AG("DT",I))
IF 'I
QUIT
Begin DoDot:1
+15 SET J=0
+16 FOR
SET J=$ORDER(AG("DT",I,J))
IF J=""
QUIT
Begin DoDot:2
+17 IF $GET(AG1("DT",I,J))'=AG("DT",I,J)
SET AGFL(5)=1
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 SET I=0
+21 FOR
SET I=$ORDER(AG1("DT",I))
IF 'I
QUIT
Begin DoDot:1
+22 SET J=0
+23 FOR
SET J=$ORDER(AG1("DT",I,J))
IF J=""
QUIT
Begin DoDot:2
+24 IF $GET(AG("DT",I,J))'=AG1("DT",I,J)
SET AGFL(5)=1
+25 QUIT
End DoDot:2
+26 QUIT
End DoDot:1
+27 QUIT
MDISP(AGDISP) ;EP - display medicare info
+1 IF AGDISP=5
SET AG1(5)="DATES"
SET AG2(5)=""
+2 FOR I=1:1:AGDISP
Begin DoDot:1
+3 WRITE !,$PIECE($TEXT(@I),";;",$SELECT(AGTYPE="D":3,1:2)),":",?13
+4 IF $GET(AGFL(I))
WRITE $$S^AGVDF("RVN")
+5 WRITE $SELECT('$LENGTH(AG1(I)):" ",I=2:$$FMTE^XLFDT(AG1(I),5),1:AG1(I))
+6 IF $GET(AGFL(I))
WRITE $$S^AGVDF("RVF")
+7 IF AGTYPE="D"
IF I=5
WRITE " ( Matching Medicaid eligibility dates are not displayed )"
+8 WRITE ?45,$SELECT(I=2:$$FMTE^XLFDT(AG2(I),5),1:AG2(I))
+9 QUIT
End DoDot:1
+10 IF AGDISP=4
WRITE !
+11 ;Dates from RPMS file.
+12 SET (AG1,AGCNT)=0
+13 KILL AGLINE
+14 FOR
SET AG1=$ORDER(AG1("DT",AG1))
IF 'AG1
QUIT
Begin DoDot:1
+15 SET AGCVT=0
+16 FOR
SET AGCVT=$ORDER(AG1("DT",AG1,AGCVT))
IF AGCVT=""
QUIT
Begin DoDot:2
+17 SET AGCNT=AGCNT+1
SET AGLINE(AGCNT)=AG1("DT",AG1,AGCVT)
+18 IF $GET(AG("DT",AG1,AGCVT))
SET $PIECE(AGLINE(AGCNT),"*",2)=AG("DT",AG1,AGCVT)
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 ;Dates from incoming file.
+22 SET AG2=0
+23 FOR
SET AG2=$ORDER(AG("DT",AG2))
IF 'AG2
QUIT
Begin DoDot:1
+24 SET AGCVT=0
+25 FOR
SET AGCVT=$ORDER(AG("DT",AG2,AGCVT))
IF AGCVT=""
QUIT
Begin DoDot:2
+26 IF $GET(AG1("DT",AG2,AGCVT))
QUIT
SET AGCNT=AGCNT+1
SET $PIECE(AGLINE(AGCNT),"*",2)=AG("DT",AG2,AGCVT)
+27 IF $PIECE(AGLINE(AGCNT),"*",1)=""
SET $PIECE(AGLINE(AGCNT),"*",1)="^^"
+28 QUIT
End DoDot:2
+29 QUIT
End DoDot:1
+30 SET (I,AGCNT)=0
+31 FOR
SET I=$ORDER(AGLINE(I))
IF 'I
QUIT
Begin DoDot:1
+32 IF AGTYPE="D"
IF $PIECE(AGLINE(I),"*",2)=""
QUIT
IF $PIECE(AGLINE(I),"*",1)=$PIECE(AGLINE(I),"*",2)
QUIT
+33 SET AGLINE(I)=$TRANSLATE(AGLINE(I),"*","^")
+34 WRITE !,"START DATE: "
+35 WRITE ?13,$$FMTE^XLFDT($PIECE(AGLINE(I),U,1),5)
+36 WRITE ?45,$SELECT('($PIECE(AGLINE(I),U,1)):IORVON,1:""),$$FMTE^XLFDT($PIECE(AGLINE(I),U,4),5),IORVOFF
+37 WRITE !," END DATE: "
+38 WRITE ?13,$$FMTE^XLFDT($PIECE(AGLINE(I),U,2),5)
+39 WRITE ?45,$SELECT('$PIECE(AGLINE(I),U,1):IORVON,($PIECE(AGLINE(I),U,5))&($PIECE(AGLINE(I),U,2)'=$PIECE(AGLINE(I),U,5)):IORVON,1:""),$SELECT($PIECE(AGLINE(I),U,5):$$FMTE^XLFDT($PIECE(AGLINE(I),U,5),5),1:$JUSTIFY("",10)),IORVOFF
+40 WRITE !," COV TYPE: ",?13,$PIECE(AGLINE(I),U,3),?45,$SELECT('$LENGTH($PIECE(AGLINE(I),U,3)):IORVON,1:""),$PIECE(AGLINE(I),U,6),IORVOFF
+41 QUIT
End DoDot:1
+42 QUIT
1 ;;MCR NAME;;MCD NAME;;
2 ;;MCR DOB;;MCD DOB;;
3 ;;MCR NUMBER;;MCD NUMBER;;
4 ;;SFX;;;;
5 ;;ELIGIBILITY;;ELIGIBILITY;;
+1 ;
FILE(AG) ;EP - file MEDICARE FIELDS
+1 IF '$DATA(^AUTTMCS("B",AG("FSFX")))
SET DIC=9999999.32
SET DIC(0)="L"
SET X=AG("FSFX")
DO ^DIC
IF +Y<1
WRITE !,"Add to MEDICARE SUFFIX file failed for '",AG("FSFX"),"'.",$$DIR^XBDIR("E")
QUIT
+2 NEW AGADD
+3 IF '$DATA(^AUPNMCR(AG("DFN"),0))
Begin DoDot:1
+4 NEW DIC,DLAYGO,DD,DO
+5 SET DIC="^AUPNMCR("
SET DIC(0)="F"
SET DLAYGO=9000003
SET (DINUM,X)=AG("DFN")
+6 SET DIC("DR")=".02////"_AGINSPT_";.03///"_AG("FNBR")_";.04///"_AG("FSFX")_";2101///"_AG("FNM")_";2102///"_AG("FDOB")
+7 KILL DD,DO
+8 DO FILE^DICN
IF +Y>0
DO PTACT(1,AG("DFN"))
+9 QUIT
End DoDot:1
IF +Y<0
QUIT
SET AGADD=1
IF 1
+10 IF '$TEST
Begin DoDot:1
+11 NEW DA,DIE,DR
+12 SET DIE="^AUPNMCR("
SET DA=AG("DFN")
SET DR=""
+13 IF $PIECE(^AUPNMCR(DA,0),U,2)'=AGINSPT
SET DR=".02////"_AGINSPT
+14 IF AG("FNBR")'=""
IF AG("FNBR")'=$PIECE(^AUPNMCR(DA,0),U,3)
SET DR=DR_$SELECT($LENGTH(DR):";",1:"")_".03///"_AG("FNBR")
+15 IF AG("FSFX")'=""
Begin DoDot:2
+16 IF $PIECE(^AUPNMCR(DA,0),U,4)
IF AG("FSFX")=$PIECE(^AUTTMCS($PIECE(^AUPNMCR(DA,0),U,4),0),U)
QUIT
+17 SET DR=DR_$SELECT($LENGTH(DR):";",1:"")_".04///"_AG("FSFX")
+18 QUIT
End DoDot:2
+19 IF AG("FNM")'=""
IF AG("FNM")'=$PIECE($GET(^AUPNMCR(DA,21)),U)
SET DR=DR_$SELECT($LENGTH(DR):";",1:"")_"2101///"_AG("FNM")
+20 IF AG("FDOB")'=""
IF AG("FDOB")'=$PIECE($GET(^AUPNMCR(DA,21)),U,2)
SET DR=DR_$SELECT($LENGTH(DR):";",1:"")_"2102////"_AG("FDOB")
+21 IF $LENGTH(DR)
NEW DITC
SET DITC=""
DO ^DIE
IF '$DATA(Y)
DO PTACT(2,AG("DFN"))
KILL DITC
+22 QUIT
End DoDot:1
SET AGADD=0
+23 ;
+24 SET DA(1)=AG("DFN")
SET DIK="^AUPNMCR("_DA(1)_",11,"
SET DA=0
+25 ;F S DA=$O(^AUPNMCR(DA(1),11,DA)) Q:'DA D ^DIK
+26 ;IHS/SD/TPF 4/25/2006 AG*7.1*2 IM20585
FOR
SET DA=$ORDER(^AUPNMCR(DA(1),11,DA))
IF 'DA
QUIT
IF $PIECE($GET(^AUPNMCR(DA(1),11,DA,0)),U,3)'="D"
DO ^DIK
+27 SET DIC="^AUPNMCR("_DA(1)_",11,"
SET DIC(0)="F"
SET DIC("P")=$PIECE(^DD(9000003,1101,0),U,2)
+28 KILL DD,DO
+29 SET AGI=0
+30 FOR
SET AGI=$ORDER(AG("DT",AGI))
IF 'AGI
QUIT
Begin DoDot:1
+31 SET AGJ=0
+32 FOR
SET AGJ=$ORDER(AG("DT",AGI,AGJ))
IF AGJ=""
QUIT
Begin DoDot:2
+33 SET X=$PIECE(AG("DT",AGI,AGJ),U,1)
+34 IF 'X
QUIT
+35 SET DIC("DR")=".02////^S X=$P(AG(""DT"",AGI,AGJ),U,2)"
+36 SET DIC("DR")=DIC("DR")_";.03////^S X=$P(AG(""DT"",AGI,AGJ),U,3)"
+37 KILL DD,DO
+38 DO FILE^DICN
+39 IF AGADD
QUIT
+40 IF +Y>0
DO PTACT(2,AG("DFN"))
+41 QUIT
End DoDot:2
+42 QUIT
End DoDot:1
+43 KILL AGI,AGJ
+44 ;
+45 Begin DoDot:1
+46 NEW DFN
+47 SET DFN=AG("DFN")
+48 DO ^AGDATCK
+49 IF $DATA(AG("ER"))
KILL AG("DATE"),AG("DTOT"),AG("ER")
QUIT
+50 DO UPDATE1^AGED(DUZ(2),AG("DFN"),4,"")
+51 QUIT
End DoDot:1
+52 QUIT
+53 ;
PTACT(AG,X) ;EP - Record action AG on patient X (DFN). 1=add, 2=edit.
+1 NEW DA,DIC,DIE,DINUM,DR,Y
+2 SET DA(1)=AGRUN
SET DIC("P")=$PIECE(^DD(9009062.02,AG,0),U,2)
SET DIC="^AGELUPLG("_DA(1)_","_AG_","
SET DIC(0)="F"
SET DINUM=X
+3 KILL DD,DO
+4 DO FILE^DICN
+5 QUIT
