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