source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTR1.m@ 1716

DGMTR1 ;ALB/CJM,SCG,LBD - Check Means Test Requirements Cont'd;3/25/92  09:51
 ;;5.3;Registration;**182,344,433,456,564**;Aug 13, 1993
 ;
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
 .;
 .;must still be effective
 .Q:($$FMDIFF^XLFDT(DT,$P(NODE0,"^"))>365)
 .Q:$$OLD^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
 .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)
 .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
 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,.52 S DGNODE(DGI)=$G(^DPT(DFN,DGI))
 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(.3),U,5)["Y"&($P(DGNODE(.3),U,2)>0)&($P(DGNODE(.362),U,20)>0) S DGMTCOR=0 G CHKQ ;UNEMPLOYABLE
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