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

DGMTR1.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1. COPYRX(DFN,MTIEN) ;
  1.  ;Creates a Pharmacy Copay test based on the means test if the vet is
  1.  ;subject to the Rx copayment and the income screening was already
  1.  ;completed
  1.  ;1/16/2002 - Changes added for LTC Copay Phase II (DG*5.3*433)
  1.  ;Creates a Pharmacy Copay test based on a LTC copay exemption test
  1.  ;(type 4) if the veteran is exempt from means test
  1.  ;
  1.  N NODE0,RXSTATUS,Y,DGMT,DGMTYPT,DGNODE,DATA,SUB,COMMENTS,RXIEN,DGMTACT,DGMTI,DGMTP,DGMTA,NODE2,CODE,QUIT,TRIES,ERROR,TYPE
  1.  ;
  1.  S DGMTP="",DGMTACT="ADD"
  1.  D ON^DGMTCOU G:'Y COPYRXQ
  1.  I $$CHK(DFN) D
  1.  .S NODE0=$G(^DGMT(408.31,MTIEN,0))
  1.  .Q:NODE0=""
  1.  .S NODE2=$G(^DGMT(408.31,MTIEN,2))
  1.  .;
  1.  .;get type of test (1=means test; 4=LTC copay exemption test)
  1.  .S TYPE=$P(NODE0,"^",19)
  1.  .;
  1.  .;must have been completed
  1.  .S CODE=$$GETCODE^DGMTH($P(NODE0,"^",3))
  1.  .S QUIT=1
  1.  .I (CODE'=""),("ACGP01"[CODE) S QUIT=0
  1.  .S CODE=$$GETCODE^DGMTH($P(NODE2,"^",3))
  1.  .I (CODE'=""),("ACGP01"[CODE) S QUIT=0
  1.  .Q:QUIT
  1.  .;
  1.  .;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
  1.  .;Q:($$FMDIFF^XLFDT(DT,$P(NODE0,"^"))>365)
  1.  .Q:$$OLDMTPF^DGMTU4($P(NODE0,"^"))
  1.  .Q:($P(NODE0,"^",14))  ;declined to provide income information
  1.  .Q:($P(NODE0,"^",26))  ;refused to sign the test
  1.  .F TRIES=1:1 D  Q:(TRIES>3)
  1.  ..S DGNODE=$$LST^DGMTU(DFN,$S((DT>$P(NODE0,"^",2)):DT,1:$P(NODE0,"^",2)),2),RXIEN=+DGNODE
  1.  ..;
  1.  ..;mark existing test as non-primary
  1.  ..I RXIEN,($E($P(DGNODE,"^",2),1,3)=$E($P(NODE0,"^"),1,3)) D
  1.  ...S DATA(2)=0 I $$UPD^DGENDBS(408.31,RXIEN,.DATA)
  1.  ..E  S TRIES=4
  1.  .;
  1.  .S RXIEN=$P(NODE2,"^",6)
  1.  .;if already copied, reuse the same record
  1.  .I RXIEN,$P($G(^DGMT(408.31,RXIEN,2)),"^",6)=MTIEN D
  1.  ..S DGMTI=RXIEN
  1.  ..; Check for another test in the current year and convert IAI records, if needed
  1.  ..S CONVRT=$$VRCHKUP^DGMTU2(2,TYPE,$P(^DGMT(408.31,MTIEN,0),"^"),$P(^DGMT(408.31,RXIEN,0),"^"))
  1.  .E  D  Q:'DGMTI
  1.  ..;This call works. Adding via the ADD^DGENDBS encountered an error
  1.  ..S DGMTDT=$P(NODE0,"^") S DGMTYPT=2 D ADD^DGMTA
  1.  .;
  1.  .S DATA(.019)=2
  1.  .S DATA(.03)=""
  1.  .F SUB=.01,.02,.04,.05,.06,.07,.14,.15,.18,.23,.24,.25 S DATA(SUB)=$P(NODE0,"^",(SUB/.01))
  1.  .S DATA(2)=1
  1.  .S DATA(2.02)=$P(NODE2,"^",2)
  1.  .S DATA(2.05)=$P(NODE2,"^",5)
  1.  .I TYPE=1 D
  1.  ..S DATA(2.06)=MTIEN
  1.  ..S COMMENTS("LINES",1,0)="This Rx Copay Test was automatically created based on a completed means test"
  1.  ..S COMMENTS("LINES",2,0)="which was changed to NO LONGER REQUIRED. All data including income"
  1.  ..S COMMENTS("LINES",3,0)="screening was copied from the test on "_$$FMTE^XLFDT($$NOW^XLFDT)_"."
  1.  .I TYPE=4 D
  1.  ..S COMMENTS("LINES",1,0)="This Rx Copay Test was automatically created based on a completed"
  1.  ..S COMMENTS("LINES",2,0)="LTC copay exemption test. All data including income screening"
  1.  ..S COMMENTS("LINES",3,0)="was copied from the test on "_$$FMTE^XLFDT($$NOW^XLFDT)_"."
  1.  .S DATA(50)="COMMENTS(""LINES"")"
  1.  .S (DATA(.03),DATA(2.03))=$$RXSTATUS(MTIEN)
  1.  .S DATA(2.11)=1
  1.  .I $$UPD^DGENDBS(408.31,DGMTI,.DATA,.ERROR)
  1.  .K DATA
  1.  .S:TYPE=1 DATA(2.06)=DGMTI
  1.  .S:TYPE=4 DATA(2.08)=DGMTI
  1.  .I $$UPD^DGENDBS(408.31,MTIEN,.DATA,.ERROR)
  1.  .D TRANSFER^DGMTU4(DFN,MTIEN,DGMTI)
  1.  .D QUE^DGMTR
  1. COPYRXQ ;
  1.  K ERROR
  1.  Q
  1.  ;
  1. RXSTATUS(MTIEN) ;
  1.  ;Determins RX Copay Status based on the means test
  1.  ;
  1.  Q:('$G(MTIEN)) ""
  1.  N NODE0,NODE,PIECE,IBSTATUS,MTSTATUS
  1.  S NODE0=$G(^DGMT(408.31,MTIEN,0))
  1.  Q:(NODE0="") ""
  1.  F PIECE=1,2,4,5,14,15,18 S $P(NODE,"^",PIECE)=$P(NODE0,"^",PIECE)
  1.  S $P(NODE,"^",19)=2
  1.  S IBSTATUS=+$$INCDT^IBARXEU1(NODE)
  1.  S MTSTATUS=$S(IBSTATUS=1:"E",IBSTATUS=2:"M",1:"")
  1.  Q:(MTSTATUS="") ""
  1.  Q $O(^DG(408.32,"AC",2,MTSTATUS,0))
  1.  ;
  1. CHK(DFN) ;
  1.  ;can the veteran take a RX copay test?
  1.  N DGMTI,DGMTCOR,DGNODE,DGELIG,DGI,DGE
  1.  S DGMTCOR=1
  1.  ;
  1.  I $P($G(^DPT(DFN,"VET")),U,1)'="Y" S DGMTCOR=0 G CHKQ ;NON-VET
  1.  S DGI=$P($G(^DPT(DFN,.36)),U) I 'DGI S DGMTCOR=0 G CHKQ ;NO PRIM ELIG
  1.  ;Begin DG*5.3*993 Registration only
  1.  I $G(DGENRYN)=0 S DGMTCOR=0 G CHKQ
  1.  I '$G(DGENRYN) N STATUS S STATUS=$$STATUS^DGENA(DFN) I STATUS=25 S DGMTCOR=0 G CHKQ
  1.  ;End DG*5.3*993
  1.  S DGELIG=U_$P($G(^DIC(8,+DGI,0)),U,9)_U
  1.  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
  1.  I (DGELIG["^1^") S DGMTCOR=0 G CHKQ  ;SC 50-100%
  1.  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
  1.  I $P(DGNODE(.362),U,12)["Y"!(DGELIG["^2^") S DGMTCOR=0 G CHKQ ;A&A
  1.  I $P(DGNODE(.362),U,13)["Y"!(DGELIG["^15^") S DGMTCOR=0 G CHKQ ;HB
  1.  I $P(DGNODE(.362),U,14)["Y"!(DGELIG["^4^") S DGMTCOR=0 G CHKQ ;PENSION
  1.  I $P(DGNODE(.52),U,5)["Y"!(DGELIG["^18^") S DGMTCOR=0 G CHKQ ;POW
  1.  I $P(DGNODE(.39),U,6)["Y"!(DGELIG["^21^") S DGMTCOR=0 G CHKQ ;CD DG*5.3*840
  1.  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
  1.  I $P(DGNODE(.54),U,1)["Y" S DGMTCOR=0 G CHKQ ;if MOH="Y" Q DG*5.3*972 HM
  1. CHKQ ;
  1.  Q DGMTCOR
  1. MAIL ; Send a mailman msg to user/ INCONSISTENCY EDIT GROUP with results
  1.  N %,DGB,I,VA,VADM,VAERR,Y,XMDUZ,XMSUB,XMTEXT,XMY,XMZ
  1.  D DEM^VADPT
  1.  S XMSUB="Patient "_VADM(1)_" has an invalid secondary eligibility"
  1.  S XMDUZ="PIMS PACKAGE",XMY(DUZ)="",XMY(.5)=""
  1.  S DGB=+$P($G(^DG(43,1,"NOT")),"^",6)
  1.  I $D(^XMB(3.8,DGB,0)) S XMY("G."_$P($G(^XMB(3.8,DGB,0)),"^"))=""
  1.  S XMTEXT="DGTXT("
  1.  D NOW^%DTC S Y=% D DD^%DT
  1.  S DGTXT(1)="On "_Y_"  "_VADM(1)_" ("_VA("BID")_")"
  1.  S DGTXT(2)="has an invalid secondary eligibility"
  1.  S DGTXT(3)="  "
  1.  ;que mailman message
  1.  N DIFROM,I,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
  1.  F I="DGTXT(","XMDUZ","XMSUB","XMTEXT","XMY(" S ZTSAVE(I)=""
  1.  S ZTDESC="MAILMAN MSG FOR INVALID ELIGIBILITY CODE FILE ENTRIES"
  1.  S ZTDTH=$$NOW^XLFDT(),ZTIO="",ZTRTN="^XMD"
  1.  D ^%ZTLOAD
  1.  Q