DGMTR1 ;ALB/CJM,SCG,LBD,BDB,HM,DSB - Check Means Test Requirements Cont'd;3/25/92 09:51
;;5.3;Registration;**182,344,433,456,564,688,840,858,972,993**;Aug 13, 1993;Build 92
;
COPYRX(DFN,MTIEN) ;
;Creates a Pharmacy Copay test based on the means test if the vet is
;subject to the Rx copayment and the income screening was already
;completed
;1/16/2002 - Changes added for LTC Copay Phase II (DG*5.3*433)
;Creates a Pharmacy Copay test based on a LTC copay exemption test
;(type 4) if the veteran is exempt from means test
;
N NODE0,RXSTATUS,Y,DGMT,DGMTYPT,DGNODE,DATA,SUB,COMMENTS,RXIEN,DGMTACT,DGMTI,DGMTP,DGMTA,NODE2,CODE,QUIT,TRIES,ERROR,TYPE
;
S DGMTP="",DGMTACT="ADD"
D ON^DGMTCOU G:'Y COPYRXQ
I $$CHK(DFN) D
.S NODE0=$G(^DGMT(408.31,MTIEN,0))
.Q:NODE0=""
.S NODE2=$G(^DGMT(408.31,MTIEN,2))
.;
.;get type of test (1=means test; 4=LTC copay exemption test)
.S TYPE=$P(NODE0,"^",19)
.;
.;must have been completed
.S CODE=$$GETCODE^DGMTH($P(NODE0,"^",3))
.S QUIT=1
.I (CODE'=""),("ACGP01"[CODE) S QUIT=0
.S CODE=$$GETCODE^DGMTH($P(NODE2,"^",3))
.I (CODE'=""),("ACGP01"[CODE) S QUIT=0
.Q:QUIT
.;
.;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
.;Q:($$FMDIFF^XLFDT(DT,$P(NODE0,"^"))>365)
.Q:$$OLDMTPF^DGMTU4($P(NODE0,"^"))
.Q:($P(NODE0,"^",14)) ;declined to provide income information
.Q:($P(NODE0,"^",26)) ;refused to sign the test
.F TRIES=1:1 D Q:(TRIES>3)
..S DGNODE=$$LST^DGMTU(DFN,$S((DT>$P(NODE0,"^",2)):DT,1:$P(NODE0,"^",2)),2),RXIEN=+DGNODE
..;
..;mark existing test as non-primary
..I RXIEN,($E($P(DGNODE,"^",2),1,3)=$E($P(NODE0,"^"),1,3)) D
...S DATA(2)=0 I $$UPD^DGENDBS(408.31,RXIEN,.DATA)
..E S TRIES=4
.;
.S RXIEN=$P(NODE2,"^",6)
.;if already copied, reuse the same record
.I RXIEN,$P($G(^DGMT(408.31,RXIEN,2)),"^",6)=MTIEN D
..S DGMTI=RXIEN
..; Check for another test in the current year and convert IAI records, if needed
..S CONVRT=$$VRCHKUP^DGMTU2(2,TYPE,$P(^DGMT(408.31,MTIEN,0),"^"),$P(^DGMT(408.31,RXIEN,0),"^"))
.E D Q:'DGMTI
..;This call works. Adding via the ADD^DGENDBS encountered an error
..S DGMTDT=$P(NODE0,"^") S DGMTYPT=2 D ADD^DGMTA
.;
.S DATA(.019)=2
.S DATA(.03)=""
.F SUB=.01,.02,.04,.05,.06,.07,.14,.15,.18,.23,.24,.25 S DATA(SUB)=$P(NODE0,"^",(SUB/.01))
.S DATA(2)=1
.S DATA(2.02)=$P(NODE2,"^",2)
.S DATA(2.05)=$P(NODE2,"^",5)
.I TYPE=1 D
..S DATA(2.06)=MTIEN
..S COMMENTS("LINES",1,0)="This Rx Copay Test was automatically created based on a completed means test"
..S COMMENTS("LINES",2,0)="which was changed to NO LONGER REQUIRED. All data including income"
..S COMMENTS("LINES",3,0)="screening was copied from the test on "_$$FMTE^XLFDT($$NOW^XLFDT)_"."
.I TYPE=4 D
..S COMMENTS("LINES",1,0)="This Rx Copay Test was automatically created based on a completed"
..S COMMENTS("LINES",2,0)="LTC copay exemption test. All data including income screening"
..S COMMENTS("LINES",3,0)="was copied from the test on "_$$FMTE^XLFDT($$NOW^XLFDT)_"."
.S DATA(50)="COMMENTS(""LINES"")"
.S (DATA(.03),DATA(2.03))=$$RXSTATUS(MTIEN)
.S DATA(2.11)=1
.I $$UPD^DGENDBS(408.31,DGMTI,.DATA,.ERROR)
.K DATA
.S:TYPE=1 DATA(2.06)=DGMTI
.S:TYPE=4 DATA(2.08)=DGMTI
.I $$UPD^DGENDBS(408.31,MTIEN,.DATA,.ERROR)
.D TRANSFER^DGMTU4(DFN,MTIEN,DGMTI)
.D QUE^DGMTR
COPYRXQ ;
K ERROR
Q
;
RXSTATUS(MTIEN) ;
;Determins RX Copay Status based on the means test
;
Q:('$G(MTIEN)) ""
N NODE0,NODE,PIECE,IBSTATUS,MTSTATUS
S NODE0=$G(^DGMT(408.31,MTIEN,0))
Q:(NODE0="") ""
F PIECE=1,2,4,5,14,15,18 S $P(NODE,"^",PIECE)=$P(NODE0,"^",PIECE)
S $P(NODE,"^",19)=2
S IBSTATUS=+$$INCDT^IBARXEU1(NODE)
S MTSTATUS=$S(IBSTATUS=1:"E",IBSTATUS=2:"M",1:"")
Q:(MTSTATUS="") ""
Q $O(^DG(408.32,"AC",2,MTSTATUS,0))
;
CHK(DFN) ;
;can the veteran take a RX copay test?
N DGMTI,DGMTCOR,DGNODE,DGELIG,DGI,DGE
S DGMTCOR=1
;
I $P($G(^DPT(DFN,"VET")),U,1)'="Y" S DGMTCOR=0 G CHKQ ;NON-VET
S DGI=$P($G(^DPT(DFN,.36)),U) I 'DGI S DGMTCOR=0 G CHKQ ;NO PRIM ELIG
;Begin DG*5.3*993 Registration only
I $G(DGENRYN)=0 S DGMTCOR=0 G CHKQ
I '$G(DGENRYN) N STATUS S STATUS=$$STATUS^DGENA(DFN) I STATUS=25 S DGMTCOR=0 G CHKQ
;End DG*5.3*993
S DGELIG=U_$P($G(^DIC(8,+DGI,0)),U,9)_U
S DGI=0 F S DGI=$O(^DPT(DFN,"E",DGI)) Q:'DGI S DGE=$P($G(^DPT(DFN,"E",DGI,0)),U),DGELIG=DGELIG_$P($G(^DIC(8,+DGE,0)),U,9)_U
I (DGELIG["^1^") S DGMTCOR=0 G CHKQ ;SC 50-100%
F DGI=.3,.362,.39,.52,.54 S DGNODE(DGI)=$G(^DPT(DFN,DGI)) ;added MOH indicator field on loop DG*5.3*972 HM
I $P(DGNODE(.362),U,12)["Y"!(DGELIG["^2^") S DGMTCOR=0 G CHKQ ;A&A
I $P(DGNODE(.362),U,13)["Y"!(DGELIG["^15^") S DGMTCOR=0 G CHKQ ;HB
I $P(DGNODE(.362),U,14)["Y"!(DGELIG["^4^") S DGMTCOR=0 G CHKQ ;PENSION
I $P(DGNODE(.52),U,5)["Y"!(DGELIG["^18^") S DGMTCOR=0 G CHKQ ;POW
I $P(DGNODE(.39),U,6)["Y"!(DGELIG["^21^") S DGMTCOR=0 G CHKQ ;CD DG*5.3*840
I $P(DGNODE(.3),U,5)["Y"&($P(DGNODE(.3),U,2)>0)&($P(DGNODE(.362),U,20)>0) S DGMTCOR=0 G CHKQ ;UNEMPLOYABLE
I $P(DGNODE(.54),U,1)["Y" S DGMTCOR=0 G CHKQ ;if MOH="Y" Q DG*5.3*972 HM
CHKQ ;
Q DGMTCOR
MAIL ; Send a mailman msg to user/ INCONSISTENCY EDIT GROUP with results
N %,DGB,I,VA,VADM,VAERR,Y,XMDUZ,XMSUB,XMTEXT,XMY,XMZ
D DEM^VADPT
S XMSUB="Patient "_VADM(1)_" has an invalid secondary eligibility"
S XMDUZ="PIMS PACKAGE",XMY(DUZ)="",XMY(.5)=""
S DGB=+$P($G(^DG(43,1,"NOT")),"^",6)
I $D(^XMB(3.8,DGB,0)) S XMY("G."_$P($G(^XMB(3.8,DGB,0)),"^"))=""
S XMTEXT="DGTXT("
D NOW^%DTC S Y=% D DD^%DT
S DGTXT(1)="On "_Y_" "_VADM(1)_" ("_VA("BID")_")"
S DGTXT(2)="has an invalid secondary eligibility"
S DGTXT(3)=" "
;que mailman message
N DIFROM,I,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
F I="DGTXT(","XMDUZ","XMSUB","XMTEXT","XMY(" S ZTSAVE(I)=""
S ZTDESC="MAILMAN MSG FOR INVALID ELIGIBILITY CODE FILE ENTRIES"
S ZTDTH=$$NOW^XLFDT(),ZTIO="",ZTRTN="^XMD"
D ^%ZTLOAD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGMTR1 5956 printed Sep 23, 2025@20:21:05 Page 2
DGMTR1 ;ALB/CJM,SCG,LBD,BDB,HM,DSB - Check Means Test Requirements Cont'd;3/25/92 09:51
+1 ;;5.3;Registration;**182,344,433,456,564,688,840,858,972,993**;Aug 13, 1993;Build 92
+2 ;
COPYRX(DFN,MTIEN) ;
+1 ;Creates a Pharmacy Copay test based on the means test if the vet is
+2 ;subject to the Rx copayment and the income screening was already
+3 ;completed
+4 ;1/16/2002 - Changes added for LTC Copay Phase II (DG*5.3*433)
+5 ;Creates a Pharmacy Copay test based on a LTC copay exemption test
+6 ;(type 4) if the veteran is exempt from means test
+7 ;
+8 NEW NODE0,RXSTATUS,Y,DGMT,DGMTYPT,DGNODE,DATA,SUB,COMMENTS,RXIEN,DGMTACT,DGMTI,DGMTP,DGMTA,NODE2,CODE,QUIT,TRIES,ERROR,TYPE
+9 ;
+10 SET DGMTP=""
SET DGMTACT="ADD"
+11 DO ON^DGMTCOU
if 'Y
GOTO COPYRXQ
+12 IF $$CHK(DFN)
Begin DoDot:1
+13 SET NODE0=$GET(^DGMT(408.31,MTIEN,0))
+14 if NODE0=""
QUIT
+15 SET NODE2=$GET(^DGMT(408.31,MTIEN,2))
+16 ;
+17 ;get type of test (1=means test; 4=LTC copay exemption test)
+18 SET TYPE=$PIECE(NODE0,"^",19)
+19 ;
+20 ;must have been completed
+21 SET CODE=$$GETCODE^DGMTH($PIECE(NODE0,"^",3))
+22 SET QUIT=1
+23 IF (CODE'="")
IF ("ACGP01"[CODE)
SET QUIT=0
+24 SET CODE=$$GETCODE^DGMTH($PIECE(NODE2,"^",3))
+25 IF (CODE'="")
IF ("ACGP01"[CODE)
SET QUIT=0
+26 if QUIT
QUIT
+27 ;
+28 ;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
+29 ;Q:($$FMDIFF^XLFDT(DT,$P(NODE0,"^"))>365)
+30 if $$OLDMTPF^DGMTU4($PIECE(NODE0,"^"))
QUIT
+31 ;declined to provide income information
if ($PIECE(NODE0,"^",14))
QUIT
+32 ;refused to sign the test
if ($PIECE(NODE0,"^",26))
QUIT
+33 FOR TRIES=1:1
Begin DoDot:2
+34 SET DGNODE=$$LST^DGMTU(DFN,$SELECT((DT>$PIECE(NODE0,"^",2)):DT,1:$PIECE(NODE0,"^",2)),2)
SET RXIEN=+DGNODE
+35 ;
+36 ;mark existing test as non-primary
+37 IF RXIEN
IF ($EXTRACT($PIECE(DGNODE,"^",2),1,3)=$EXTRACT($PIECE(NODE0,"^"),1,3))
Begin DoDot:3
+38 SET DATA(2)=0
IF $$UPD^DGENDBS(408.31,RXIEN,.DATA)
End DoDot:3
+39 IF '$TEST
SET TRIES=4
End DoDot:2
if (TRIES>3)
QUIT
+40 ;
+41 SET RXIEN=$PIECE(NODE2,"^",6)
+42 ;if already copied, reuse the same record
+43 IF RXIEN
IF $PIECE($GET(^DGMT(408.31,RXIEN,2)),"^",6)=MTIEN
Begin DoDot:2
+44 SET DGMTI=RXIEN
+45 ; Check for another test in the current year and convert IAI records, if needed
+46 SET CONVRT=$$VRCHKUP^DGMTU2(2,TYPE,$PIECE(^DGMT(408.31,MTIEN,0),"^"),$PIECE(^DGMT(408.31,RXIEN,0),"^"))
End DoDot:2
+47 IF '$TEST
Begin DoDot:2
+48 ;This call works. Adding via the ADD^DGENDBS encountered an error
+49 SET DGMTDT=$PIECE(NODE0,"^")
SET DGMTYPT=2
DO ADD^DGMTA
End DoDot:2
if 'DGMTI
QUIT
+50 ;
+51 SET DATA(.019)=2
+52 SET DATA(.03)=""
+53 FOR SUB=.01,.02,.04,.05,.06,.07,.14,.15,.18,.23,.24,.25
SET DATA(SUB)=$PIECE(NODE0,"^",(SUB/.01))
+54 SET DATA(2)=1
+55 SET DATA(2.02)=$PIECE(NODE2,"^",2)
+56 SET DATA(2.05)=$PIECE(NODE2,"^",5)
+57 IF TYPE=1
Begin DoDot:2
+58 SET DATA(2.06)=MTIEN
+59 SET COMMENTS("LINES",1,0)="This Rx Copay Test was automatically created based on a completed means test"
+60 SET COMMENTS("LINES",2,0)="which was changed to NO LONGER REQUIRED. All data including income"
+61 SET COMMENTS("LINES",3,0)="screening was copied from the test on "_$$FMTE^XLFDT($$NOW^XLFDT)_"."
End DoDot:2
+62 IF TYPE=4
Begin DoDot:2
+63 SET COMMENTS("LINES",1,0)="This Rx Copay Test was automatically created based on a completed"
+64 SET COMMENTS("LINES",2,0)="LTC copay exemption test. All data including income screening"
+65 SET COMMENTS("LINES",3,0)="was copied from the test on "_$$FMTE^XLFDT($$NOW^XLFDT)_"."
End DoDot:2
+66 SET DATA(50)="COMMENTS(""LINES"")"
+67 SET (DATA(.03),DATA(2.03))=$$RXSTATUS(MTIEN)
+68 SET DATA(2.11)=1
+69 IF $$UPD^DGENDBS(408.31,DGMTI,.DATA,.ERROR)
+70 KILL DATA
+71 if TYPE=1
SET DATA(2.06)=DGMTI
+72 if TYPE=4
SET DATA(2.08)=DGMTI
+73 IF $$UPD^DGENDBS(408.31,MTIEN,.DATA,.ERROR)
+74 DO TRANSFER^DGMTU4(DFN,MTIEN,DGMTI)
+75 DO QUE^DGMTR
End DoDot:1
COPYRXQ ;
+1 KILL ERROR
+2 QUIT
+3 ;
RXSTATUS(MTIEN) ;
+1 ;Determins RX Copay Status based on the means test
+2 ;
+3 if ('$GET(MTIEN))
QUIT ""
+4 NEW NODE0,NODE,PIECE,IBSTATUS,MTSTATUS
+5 SET NODE0=$GET(^DGMT(408.31,MTIEN,0))
+6 if (NODE0="")
QUIT ""
+7 FOR PIECE=1,2,4,5,14,15,18
SET $PIECE(NODE,"^",PIECE)=$PIECE(NODE0,"^",PIECE)
+8 SET $PIECE(NODE,"^",19)=2
+9 SET IBSTATUS=+$$INCDT^IBARXEU1(NODE)
+10 SET MTSTATUS=$SELECT(IBSTATUS=1:"E",IBSTATUS=2:"M",1:"")
+11 if (MTSTATUS="")
QUIT ""
+12 QUIT $ORDER(^DG(408.32,"AC",2,MTSTATUS,0))
+13 ;
CHK(DFN) ;
+1 ;can the veteran take a RX copay test?
+2 NEW DGMTI,DGMTCOR,DGNODE,DGELIG,DGI,DGE
+3 SET DGMTCOR=1
+4 ;
+5 ;NON-VET
IF $PIECE($GET(^DPT(DFN,"VET")),U,1)'="Y"
SET DGMTCOR=0
GOTO CHKQ
+6 ;NO PRIM ELIG
SET DGI=$PIECE($GET(^DPT(DFN,.36)),U)
IF 'DGI
SET DGMTCOR=0
GOTO CHKQ
+7 ;Begin DG*5.3*993 Registration only
+8 IF $GET(DGENRYN)=0
SET DGMTCOR=0
GOTO CHKQ
+9 IF '$GET(DGENRYN)
NEW STATUS
SET STATUS=$$STATUS^DGENA(DFN)
IF STATUS=25
SET DGMTCOR=0
GOTO CHKQ
+10 ;End DG*5.3*993
+11 SET DGELIG=U_$PIECE($GET(^DIC(8,+DGI,0)),U,9)_U
+12 SET DGI=0
FOR
SET DGI=$ORDER(^DPT(DFN,"E",DGI))
if 'DGI
QUIT
SET DGE=$PIECE($GET(^DPT(DFN,"E",DGI,0)),U)
SET DGELIG=DGELIG_$PIECE($GET(^DIC(8,+DGE,0)),U,9)_U
+13 ;SC 50-100%
IF (DGELIG["^1^")
SET DGMTCOR=0
GOTO CHKQ
+14 ;added MOH indicator field on loop DG*5.3*972 HM
FOR DGI=.3,.362,.39,.52,.54
SET DGNODE(DGI)=$GET(^DPT(DFN,DGI))
+15 ;A&A
IF $PIECE(DGNODE(.362),U,12)["Y"!(DGELIG["^2^")
SET DGMTCOR=0
GOTO CHKQ
+16 ;HB
IF $PIECE(DGNODE(.362),U,13)["Y"!(DGELIG["^15^")
SET DGMTCOR=0
GOTO CHKQ
+17 ;PENSION
IF $PIECE(DGNODE(.362),U,14)["Y"!(DGELIG["^4^")
SET DGMTCOR=0
GOTO CHKQ
+18 ;POW
IF $PIECE(DGNODE(.52),U,5)["Y"!(DGELIG["^18^")
SET DGMTCOR=0
GOTO CHKQ
+19 ;CD DG*5.3*840
IF $PIECE(DGNODE(.39),U,6)["Y"!(DGELIG["^21^")
SET DGMTCOR=0
GOTO CHKQ
+20 ;UNEMPLOYABLE
IF $PIECE(DGNODE(.3),U,5)["Y"&($PIECE(DGNODE(.3),U,2)>0)&($PIECE(DGNODE(.362),U,20)>0)
SET DGMTCOR=0
GOTO CHKQ
+21 ;if MOH="Y" Q DG*5.3*972 HM
IF $PIECE(DGNODE(.54),U,1)["Y"
SET DGMTCOR=0
GOTO CHKQ
CHKQ ;
+1 QUIT DGMTCOR
MAIL ; Send a mailman msg to user/ INCONSISTENCY EDIT GROUP with results
+1 NEW %,DGB,I,VA,VADM,VAERR,Y,XMDUZ,XMSUB,XMTEXT,XMY,XMZ
+2 DO DEM^VADPT
+3 SET XMSUB="Patient "_VADM(1)_" has an invalid secondary eligibility"
+4 SET XMDUZ="PIMS PACKAGE"
SET XMY(DUZ)=""
SET XMY(.5)=""
+5 SET DGB=+$PIECE($GET(^DG(43,1,"NOT")),"^",6)
+6 IF $DATA(^XMB(3.8,DGB,0))
SET XMY("G."_$PIECE($GET(^XMB(3.8,DGB,0)),"^"))=""
+7 SET XMTEXT="DGTXT("
+8 DO NOW^%DTC
SET Y=%
DO DD^%DT
+9 SET DGTXT(1)="On "_Y_" "_VADM(1)_" ("_VA("BID")_")"
+10 SET DGTXT(2)="has an invalid secondary eligibility"
+11 SET DGTXT(3)=" "
+12 ;que mailman message
+13 NEW DIFROM,I,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+14 FOR I="DGTXT(","XMDUZ","XMSUB","XMTEXT","XMY("
SET ZTSAVE(I)=""
+15 SET ZTDESC="MAILMAN MSG FOR INVALID ELIGIBILITY CODE FILE ENTRIES"
+16 SET ZTDTH=$$NOW^XLFDT()
SET ZTIO=""
SET ZTRTN="^XMD"
+17 DO ^%ZTLOAD
+18 QUIT
