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

DGMTR.m

Go to the documentation of this file.
  1. DGMTR ;ALB/RMO,CAW,SCG,AEG,SCG,AEG,LBD - Check Means Test Requirements;7/8/05 2:30pm
  1. ;;5.3;PIMS;**45,93,114,137,141,147,177,182,146,305,326,314,344,402,426,456,495,672,688,1015,1016**;JUN 30, 2012;Build 20
  1. ;A patient requires a means test under the following conditions:
  1. ; - Primary Eligibility is NSC OR patient is SC 0% non-compensable
  1. ; - who is NOT receiving disability retirement from the military
  1. ; - who is NOT eligible for medicaid
  1. ; - who is NOT on a DOM ward
  1. ; - who has NOT been means tested in the past year
  1. ; - who is NOT a Purple Heart recipient
  1. ; - who is NOT Catastrophically Disabled
  1. ; - who is NOT a Medal of Honor recipient
  1. ; Input -- DFN Patient IEN
  1. ; DGADDF Means Test Add Flag (Optional- default none)
  1. ; (1 if using the 'Add a New Means Test' option)
  1. ; DGMSGF Means Test Msg Flag (Optional- default none)
  1. ; (1 to suppress messages)
  1. ; DGNOIVMUPD No IVM Update Flag (Optional - default allow)
  1. ; (1 if updating of an IVM test is not allowed)
  1. ; Output -- DGREQF Means Test Require Flag
  1. ; (1 if required and 0 if not required)
  1. ; DGDOM1 DOM Patient Flag (defined and set to 1 if
  1. ; patient currently on a DOM ward)
  1. ; DGNOCOPF = 1 to suppress copay test prompt 0 otherwise
  1. ; used in CP^DG10. Killed there as well.
  1. ; If NOT using the 'Add a New Means Test' option,
  1. ; a REQUIRED date of test will be added for the
  1. ; patient if it is required.
  1. ; If a means test is required and the current
  1. ; status is NO LONGER REQUIRED, the last date of
  1. ; test and current means test status will be
  1. ; updated to REQUIRED unless the DGNOIVMUPD flag is set to 1
  1. ; and the current primary means test is an IVM test.
  1. ; If a means test is no longer required the
  1. ; last date of test and the current means test
  1. ; status will also be updated to NO LONGER REQUIRED unless
  1. ; the DGNOIVMUPD flag is set to 1 and the current primary
  1. ; means test is an IVM test.
  1. EN N DGCS,DGDOM,DGMT0,DGMTI,DGMTYPT,OLD,DGRGAUTO,DGQSENT,DGMTLTD,DGMDOD,DGMTDT
  1. ;DG*5.3*146 change to exit if during patient merge process
  1. Q:$G(VAFCA08)=1
  1. ;DGMTCOR is needed if uploading copay test
  1. I $G(RXPRIME)'="DGMTU4" N DGMTCOR
  1. S (DGQSENT,DGREQF)=0,(OLD,DGMTYPT)=1
  1. I $D(^DPT(DFN,.36)) S X=^(.36) D
  1. . I $P($G(^DIC(8,+X,0)),"^",9)=5!($$SC(DFN)) S DGREQF=1
  1. . I $P(X,"^",12)=1 S DGREQF=0 ;new field, DG 672
  1. . I $P(X,"^",13)=1 S DGREQF=0 ;new field, DG 672
  1. S (DGMTI,DGMT0)="",DGMTI=+$$LST^DGMTU(DFN)
  1. S:DGMTI DGMT0=$G(^DGMT(408.31,DGMTI,0))
  1. ;Added with DG*5.3*344
  1. S:DGMTI DGMTDT=$P(DGMT0,U)
  1. S DGMDOD=$P($G(^DPT(DFN,.35)),U)
  1. I 'DGMTI,$G(DGMDOD) D EN^DGMTCOR S DGREQF=0 Q
  1. I DGREQF S:$G(^DPT(DFN,.38)) DGREQF=0
  1. I DGREQF D DOM S:$G(DGDOM) DGREQF=0
  1. S DGCS=$P(DGMT0,"^",3)
  1. S DGMTLTD=+DGMT0,DGNOCOPF=0
  1. I +$G(DGMDOD) S DGNOCOPF=1
  1. I DGCS S OLD=$$OLD^DGMTU4(+DGMT0)
  1. ;Purple Heart Recipient ;brm 10/02/00 added 1 line below
  1. I $P($G(^DPT(DFN,.53)),U)="Y" S DGREQF=0
  1. ;Catastrophically disabled
  1. I $P($G(^DPT(DFN,.39)),U,6)="Y" S DGREQF=0 ;DG*5.3*840
  1. ;Medal of Honor DG*5.3*840
  1. I $P($G(^DPT(DFN,.54)),U)="Y" S DGREQF=0
  1. D
  1. .I DGREQF,DGCS=3,'OLD D REQ Q
  1. .I DGREQF,'$G(DGADDF),((DGCS=6)!(DGCS=2)),$P(DGMT0,U,11)=1,DGMTLTD>2991005 S DGREQF=0,DGNOCOPF=1 Q
  1. .; next line added 2/19/02 - DG*5.3*426
  1. .I DGREQF,'$G(DGADDF),$G(DGCS)=6,+$P(DGMT0,U,14),+$P(DGMT0,U,11) S DGREQF=0,DGNOCOPF=1 Q
  1. .I DGREQF,'$G(DGADDF),(('DGCS)!(OLD)),'$G(DGMDOD) D ADD Q
  1. .I 'DGREQF,DGCS,DGCS'=3,'$G(DGDOM),'$G(DGMDOD),'+$G(IVMZ10F) D NOL Q
  1. ;be sure to check whether or not patient is subject to RX copay!
  1. D EN^DGMTCOR
  1. Q
  1. ;Check if patient is in a DOM
  1. ; call to DOM checks if patient currently on a DOM ward
  1. ; (called from EN)
  1. ; call to DOM1 checks if patient on a DOM ward for a specific date
  1. ; before call to DOM1 - N VAINDT,VADMVT,DGDOM,DGDOM1
  1. ; S VAINDT=specific date
  1. ; S DFN=Patient IEN
  1. ; output - DGDOM & DGDOM1 (defined and set to 1 if
  1. ; patient on a DOM ward for specific date)
  1. DOM N VAINDT,VADMVT
  1. DOM1 D ADM^VADPT2
  1. I VADMVT,$P($G(^DG(43,1,0)),"^",21),$D(^DIC(42,+$P($G(^DGPM(VADMVT,0)),"^",6),0)),$P(^(0),"^",3)="D" S (DGDOM,DGDOM1)=1
  1. Q
  1. SC(DFN) ;Check if patient is SC 0% non-compensable
  1. ; Input -- DFN Patient IEN
  1. ; Output -- 1=Yes and 0=No
  1. ; No if:
  1. ; No total annual VA check amount
  1. ; POW STATUS INDICATOR is yes
  1. ; Secondary Eligibility is one of the following:
  1. ; A&A, NSC, VA PENSION
  1. ; HOUSEBOUND, MEXICAN BORDER WAR, WWI, POW
  1. N DG,DGE,DGF,Y
  1. S Y=0
  1. ;Primary eligibility is SC LESS THAN 50%
  1. I $D(^DPT(DFN,.36)),$P($G(^DIC(8,+^(.36),0)),"^",9)=3 S Y=1
  1. G:'Y SCQ
  1. ;Service connected percentage is 0
  1. I $P($G(^DPT(DFN,.3)),"^",2)'=0 S Y=0 G SCQ
  1. ;No Total annual VA check amount
  1. I $P($G(^DPT(DFN,.362)),"^",20) S Y=0 G SCQ
  1. ;POW STATUS INDICATOR
  1. I $P($G(^DPT(DFN,.52)),"^",5)="Y" S Y=0 G SCQ
  1. ;Purple Heart Indicator
  1. I $P($G(^DPT(DFN,.53)),"^")="Y" S Y=0 G SCQ
  1. ;Secondary Eligibility
  1. F DG=2,4,15:1:18 S DGE(DG)=""
  1. S DG=0 F S DG=$O(^DPT(DFN,"E","B",DG)) Q:'DG D SELIG I DGF,$D(DGE(+DGF)) S Y=0 Q
  1. SCQ Q +$G(Y)
  1. ADD ;Add a required means test
  1. N DGMTA,DGMTACT,DGMTDT,DGMTI,DGMTP,ERROR
  1. W:'$G(DGMSGF) !,"MEANS TEST REQUIRED"
  1. S DGMTACT="ADD" D PRIOR^DGMTEVT
  1. S DGMTDT=DT D ADD^DGMTA
  1. I DGMTI>0 S DGMTYPT=1 D
  1. .N DATA S DATA(.03)=$$GETSTAT^DGMTH("R",1) I $$UPD^DGENDBS(408.31,DGMTI,.DATA)
  1. .D GETINCOM^DGMTU4(DFN,DT)
  1. .D QUE
  1. I $G(IVMZ10)'="UPLOAD IN PROGRESS",'$$OPEN^IVMCQ2(DFN),'$$SENT^IVMCQ2(DFN) D QRYQUE2^IVMCQ2(DFN,$G(DUZ),0,$G(XQY)) S DGQSENT=1 I '$D(ZTQUEUED),'$G(DGMSGF) W !!,"Financial query queued to be sent to HEC..."
  1. Q
  1. REQ ;Update means test status to REQUIRED
  1. N DGMTA,AUTOCOMP,DGMTE,ERROR
  1. ;may have set prior MT for means test upload
  1. I $G(MTPRIME)'="DGMTU4" N DGMTP,DGMTACT S DGMTACT="STA" D PRIOR^DGMTEVT
  1. S AUTOCOMP=$$AUTOCOMP(DGMTI)
  1. ;if a test were auto-completed, don't want another being added inadvertently
  1. I AUTOCOMP,$G(DGADDF) S DGADDF=0
  1. I AUTOCOMP S DGCS=$P($G(^DGMT(408.31,DGMTI,0)),"^",3)
  1. I $G(IVMZ10)'="UPLOAD IN PROGRESS",'AUTOCOMP,'$$OPEN^IVMCQ2(DFN),'$$SENT^IVMCQ2(DFN) D QRYQUE2^IVMCQ2(DFN,$G(DUZ),0,$G(XQY)) S DGQSENT=1 I '$D(ZTQUEUED),'$G(DGMSGF) W !!,"Financial query queued to be sent to HEC..."
  1. I ('AUTOCOMP),('$G(DGMSGF)) W !,"MEANS TEST REQUIRED"
  1. I (AUTOCOMP),('$G(DGMSGF)) W !,"CURRENT MEANS TEST STATUS IS ",$$GETNAME^DGMTH(DGCS)
  1. S DGMTYPT=1
  1. D QUE
  1. Q
  1. AUTOCOMP(DGMTI) ;
  1. ;Will either automatically complete the test (RX copay or means test)
  1. ;based on the Test Determined Status, or will change the status to
  1. ;Required for means tests or Incomplete for Rx copay tests
  1. ;Input:
  1. ; DGMTI - the ien of the test
  1. ;Output:
  1. ; Function value - 1 if the test was completed, 0 otherwise
  1. N NODE0,NODE2,DATA,RET,LINKIEN,DGINR,DGINI,ERROR,CODE,TYPE,DFN,TDATE
  1. S RET=0
  1. Q:'$G(DGMTI) RET
  1. S NODE0=$G(^DGMT(408.31,DGMTI,0))
  1. Q:(NODE0="") RET
  1. S TYPE=$P(NODE0,"^",19)
  1. S DFN=$P(NODE0,"^",2)
  1. S TDATE=+NODE0
  1. S NODE2=$G(^DGMT(408.31,DGMTI,2))
  1. ;get test-determined status code
  1. S CODE=$$GETCODE^DGMTH($P(NODE2,"^",3))
  1. ;if means test
  1. I TYPE=1 D
  1. .S DATA(.03)=$$GETSTAT^DGMTH("R",1),DATA(.17)=""
  1. .I (CODE'=""),"ACGP"[CODE D
  1. ..S RET=1
  1. ..S DATA(.03)=$P(NODE2,"^",3)
  1. ..;determine status if there is a hardship
  1. ..I $P(NODE0,"^",20) D
  1. ...S DATA(.03)=$$GETSTAT^DGMTH($S(CODE="P":"P",CODE="C"&($P(NODE0,U,27)>$P(NODE0,U,12)):"G",1:"A"),1)
  1. .I (CODE="")!(CODE'=""&"ACGP"'[CODE) D
  1. ..; Check for another test in the current year and convert IAI records, if needed
  1. ..S CONVRT=$$VRCHKUP^DGMTU2(1,,TDATE)
  1. ..S DATA(2.11)=1
  1. ;RX copay test
  1. I TYPE=2 D
  1. .S DATA(.03)=$$GETSTAT^DGMTH("I",2),DATA(.17)=""
  1. .I (CODE'=""),"EM"[CODE D
  1. ..S RET=1
  1. ..S DATA(.03)=$P(NODE2,"^",3)
  1. .I (CODE="")!(CODE'=""&"EM"'[CODE) D
  1. ..; Check for another test in the current year and convert IAI records, if needed
  1. ..S CONVRT=$$VRCHKUP^DGMTU2(2,,TDATE)
  1. ..S DATA(2.11)=1
  1. I '$$UPD^DGENDBS(408.31,DGMTI,.DATA,.ERROR) W:'$G(DGMSGF) ERROR
  1. ;restore the pointers from the Income Relation file (408.22) to this
  1. ;test, using the linked test
  1. S LINKIEN=$P(NODE2,"^",6)
  1. I LINKIEN D
  1. .S DGINI=0 F S DGINI=$O(^DGMT(408.22,"AMT",LINKIEN,DFN,DGINI)) Q:'DGINI S DGINR=$O(^DGMT(408.22,"AMT",LINKIEN,DFN,DGINI,"")) I $P($G(^DGMT(408.22,+DGINR,"MT")),"^")]"" D
  1. ..K DATA
  1. ..S DATA(31)=DGMTI
  1. ..I $$UPD^DGENDBS(408.22,+DGINR,.DATA)
  1. D GETINCOM^DGMTU4(DFN,TDATE)
  1. Q RET
  1. NOL ;Update means test status to NO LONGER REQUIRED
  1. N DGMTA,DGINI,DGINR,DGMTDT,DATA
  1. I $G(DGNOIVMUPD),$$IVMCVT^DGMTCOR(DGMTI) D G NOLQ ; Check for converted IVM MT
  1. . ;I '$G(DGMSGF),$G(DGNOIVMUPD)<2 W !,"IVM MEANS TEST EXISTS, BUT VISTA CALCULATES 'NO LONGER REQUIRED'",!,"CONTACT IVM TO CLEAR UP THE DISCREPANCY - YOU CANNOT UPDATE AN IVM TEST"
  1. . S DGNOIVMUPD=2 ; Prevent double printing of the message
  1. W:'$G(DGMSGF) !,"MEANS TEST NO LONGER REQUIRED"
  1. ;may have set prior MT for means test upload
  1. I $G(MTPRIME)'="DGMTU4" N DGMTP,DGMTACT S DGMTACT="STA" D PRIOR^DGMTEVT
  1. ;save the Test Determined Status
  1. D SAVESTAT^DGMTU4(DGMTI)
  1. S DATA(.03)=3,DATA(.17)=DT I $$UPD^DGENDBS(408.31,DGMTI,.DATA)
  1. D QUE
  1. ;create a Rx copay test based on MT if needed
  1. D COPYRX^DGMTR1(DFN,DGMTI)
  1. NOLQ Q
  1. SET ;Set Cross-reference
  1. N D0,DA,DIV,DGIX,X
  1. S DA=DGIEN,X=DGVAL,DGIX=0
  1. F S DGIX=$O(^DD(DGFL,DGFLD,1,DGIX)) Q:'DGIX X ^(DGIX,1) S X=DGVAL
  1. Q
  1. KILL ;Kill Cross-reference
  1. N D0,DA,DIV,DGIX,X
  1. S DA=DGIEN,X=DGVAL,DGIX=0
  1. F S DGIX=$O(^DD(DGFL,DGFLD,1,DGIX)) Q:'DGIX X ^(DGIX,2) S X=DGVAL
  1. Q
  1. QUE ;Queue means test event driver
  1. D AFTER^DGMTEVT
  1. S ZTDESC="MEANS TEST EVENT DRIVER",ZTDTH=$H,ZTRTN="EN^DGMTEVT"
  1. F I="DFN","DGMTACT","DGMTI","DGMTP","DGMTA","DGMTYPT" S ZTSAVE(I)=""
  1. S ZTSAVE("DGMTINF")=1
  1. I $D(IVMZ10) S ZTSAVE("IVMZ10")=""
  1. I $D(DGENUPLD) S ZTSAVE("DGENUPLD")=""
  1. S ZTIO="" D ^%ZTLOAD
  1. K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
  1. Q
  1. SELIG ;Check if secondary eligibility code missing from ELIGIBILITY CODE
  1. ;file (#8) or entry in file #8 not pointing to MAS ELIGIBILITY
  1. ;CODE file (#8.1)
  1. N DGTXT
  1. S DGF=$G(^DIC(8,+DG,0)) I DGF="" D Q
  1. .S DGTXT(4)="Entry with an IEN OF "_DG_" missing from"
  1. .S DGTXT(5)="the ELIGIBILITY CODE file (#8)"
  1. .D MAIL^DGMTR1
  1. .Q
  1. S DGF=$P(DGF,"^",9) I DGF=""!('$D(^DIC(8.1,+DGF,0))) D
  1. .S DGTXT(4)="ELIGIBILITY CODE file (#8) entry with an IEN OF "_DG_" doesn't"
  1. .S DGTXT(5)="have a valid pointer to the MAS ELIGIBILITY CODE file (#8.1)"
  1. .D MAIL^DGMTR1
  1. .S DGF=""
  1. .Q
  1. Q