DG311PIR ;ALB/JJG-Total Dependents Calculation Utility ; 07 AUG 2000
;;5.3;Registration;**311**;Aug 13, 1993
;
; This routine will be run as a post-installation routine for patch
; DG*5.3*311. The main purpose for this routine is to recalculate
; the TOTAL DEPENDENTS field (408.31,.18) of the ANNUAL MEANS TEST file
; (#408.31). This field may have been set incorrectly as a result of
; a recent modification to routine DGMTU11 that was released as part of
; patch DG*5.3*291.
;
POST ;entry point for post-install, setting up checkpoints
N %
I $D(XPDNM) S %=$$NEWCP^XPDUTL("DGMTDT","MAIN^DG311PIR",0)
Q
MAIN ;Main Driver
N DGRECNT,DGLY,DGMTPAR
S U="^",DGRECNT=0
D BMES^XPDUTL(" Starting post-install process...")
S DGLY=2990000 ;Last Year, required by PAR^DGMTSCU
D PAR^DGMTSCU
D LOOP
D MAIN^DG311PTR ; Clean up any invalid '0' pointers to Patient Relation
D BMES^XPDUTL(" Post-install process has completed.")
D BMES^XPDUTL(" "_DGRECNT_" total records have been identified and corrected.")
Q
LOOP ; Locate and correct incorrect TOTAL DEPENDENTS field
N DGMTDT,DGIEN31,DGNOD31,DGIEN2,DGSTA,DGTOTD,DGMTYPT,DGDEPC,DGPAY,DGDEC
N DGHARD
S DGMTDT=3000705 ;Patch DG*5.3*291 release date
I $D(XPDNM) S DGMTDT=+$$PARCP^XPDUTL("DGMTDT")
S:(DGMTDT<3000705) DGMTDT=3000705
F S DGMTDT=$O(^DGMT(408.31,"B",DGMTDT)) Q:'DGMTDT D
.S DGIEN31=0
.F S DGIEN31=$O(^DGMT(408.31,"B",DGMTDT,DGIEN31)) Q:'DGIEN31 D
. .S DGNOD31=$G(^DGMT(408.31,DGIEN31,0))
. .S DGIEN2=$P(DGNOD31,"^",2) Q:'DGIEN2
. .S DGSTA=$P(DGNOD31,"^",3) ;Means Test Status
. .S DGMTYPT=$P(DGNOD31,"^",19) ;Type of Test: 1=Means Test 2=Copay Test
. .S DGTOTD=$P(DGNOD31,"^",18) ;Total Dependents
. .S DGPAY=$P(DGNOD31,"^",11) ;Agreed To Pay Deductible
. .S DGDEC=$P(DGNOD31,"^",14) ;Declines To Give Income Info.
. .S DGHARD=$P(DGNOD31,"^",20) ;Hardship?
. .D GETREL^DGMTU11(DGIEN2,"VSC",DGMTDT,DGIEN31) ; Recalculate Total Dependents minus spouse
. .S DGDEPC=DGDEP
. .S:$G(DGREL("S")) DGDEPC=DGDEPC+1 ; Include the spouse as DGMTU11 only returns children
. .I (DGTOTD!DGDEPC)&(DGTOTD'=DGDEPC) D UPDATE
. .I $D(XPDNM) S %=$$UPCP^XPDUTL("DGMTDT",DGMTDT) ; Update Checkpoint
Q
UPDATE ;Update .18 field of ANNUAL MEANS TEST file
N DATA,DGENDA,ERROR,DFN,DGMTI,DGVIRI,DGVINI,DGMTACT,DGMTI,DGMTINF,DGREL,DGPRIEN,DGUPSW
S DFN=DGIEN2,DGMTI=DGIEN31,(DGVIRI,DGREL,DGUPSW)=""
F S:(DGREL'=1) DGVIRI=$O(^DGMT(408.22,"B",DFN,DGVIRI),-1) Q:DGREL=1!('DGVIRI) D
.S DGVINI=$P($G(^DGMT(408.22,DGVIRI,0)),U,2)
.Q:'DGVINI
.S DGPRIEN=$P($G(^DGMT(408.21,DGVINI,0)),U,2) ; Pointer to PATIENT RELATION file (#408.12)
.Q:'DGPRIEN
.S DGREL=$P($G(^DGPR(408.12,DGPRIEN,0)),U,2) ;Pointer to RELATIONSHIP file (#408.11)
.I DGREL=1 S DATA(.13)=DGDEP,DGENDA=DGVIRI,ERROR="" D
.. I $$UPD^DGENDBS(408.22,.DGENDA,.DATA,.ERROR) Q
Q:DGREL'=1 ; Quit if relationship is not 'SELF'
D:(DGSTA=4)!(DGMTYPT=2&(DGSTA=7)) SET^DGMTSCU2 ;only make call if current status is 'Cat A'. Or, if copay test, only make call for status of 'Exempt'.
K DATA
S DATA(.18)=DGDEPC ; Newly derived Total # of dependents
; In the following 2 lines, only want to update Status and associated
; fields if current status is 'Cat A', and 'Hardship' flag is not 'YES'.
; For copay test, only update status and associated fields if current
; status is 'Exempt' and 'Hardship' flag is not 'YES'.
I (DGSTA=4),'DGHARD S DGUPSW=1
I DGMTYPT=2&(DGSTA=7),'DGHARD S DGUPSW=1
I DGUPSW D
.S DATA(.03)=DGMTS ; Newly derived Status
.S DATA(.12)=DGTHA ; Newly derived Threshold A field
.S DATA(2.03)=DGMTS ; Newly derived Test Determined Status
I (DGSTA'=4)&(DGSTA'=7) S DGMTS=DGSTA ; need DGMTS for build of ^XTMP
S DGENDA=DGIEN31,ERROR=""
S DGMTACT="EDT",DGMTI=DGENDA,DGMTINF=1 ; Needed for call to DGMTEVT
D PRIOR^DGMTEVT
I $$UPD^DGENDBS(408.31,.DGENDA,.DATA,.ERROR) D
.D AFTER^DGMTEVT
.D EN^DGMTEVT ; Call to Means Test Event Driver
.S DGRECNT=DGRECNT+1
.D BUILDLN
.D ATRXREF
Q
;
BUILDLN ; Build storage array with data
;
;Output:
; ^XTMP("DG311PIR",pt name,pt ssn,income year,old status,new status)=""
;
N DGNAME,DGSSN,DGINY
;
; - pt name and ssn from Patient (#2) file
S DGNAME=$P($G(^DPT(DFN,0)),"^"),DGSSN=$P($G(^(.36)),"^",3)
S:DGNAME="" DGNAME=DFN
S:DGSSN="" DGSSN="MISSING"
S Y=DGMTDT
D DD^%DT
S DGINY=$P(Y," ",3)
;
S ^XTMP("DG311PIR",DGNAME,DGSSN,DGINY,DGSTA,DGMTS)=""
Q
;
ATRXREF ; Add entry into the 'ATR' cross reference of the IVM PATIENT (#301.5)
; file so that demographic and income information will be transmitted
; to the IVM Center.
;
N IVIEN,IVNOD,IVIY,IVLAST,IVSF,IVTS
S IVIEN="",IVLAST=0,IVLIEN=""
F S IVIEN=$O(^IVM(301.5,"B",DGIEN2,IVIEN)) Q:'IVIEN D
. S IVNOD=^IVM(301.5,IVIEN,0)
. S IVIY=$P(IVNOD,U,2)
. S:(IVIY>IVLAST) IVLAST=IVIY,IVLIEN=IVIEN
I (IVLIEN'="") D
. S ^IVM(301.5,"ATR",0,IVLIEN)=""
. S IVTS=$P(IVNOD,U,3) ; Transmission Status Flag
. S IVSF=$P(IVNOD,U,4) ; Stop Flag
. I IVTS!IVSF D
.. K DATA
.. S DATA(.03)=0,DATA(.04)=0,ERROR=""
.. I $$UPD^DGENDBS(301.5,.IVLIEN,.DATA,.ERROR) Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG311PIR 5150 printed Dec 13, 2024@02:35:25 Page 2
DG311PIR ;ALB/JJG-Total Dependents Calculation Utility ; 07 AUG 2000
+1 ;;5.3;Registration;**311**;Aug 13, 1993
+2 ;
+3 ; This routine will be run as a post-installation routine for patch
+4 ; DG*5.3*311. The main purpose for this routine is to recalculate
+5 ; the TOTAL DEPENDENTS field (408.31,.18) of the ANNUAL MEANS TEST file
+6 ; (#408.31). This field may have been set incorrectly as a result of
+7 ; a recent modification to routine DGMTU11 that was released as part of
+8 ; patch DG*5.3*291.
+9 ;
POST ;entry point for post-install, setting up checkpoints
+1 NEW %
+2 IF $DATA(XPDNM)
SET %=$$NEWCP^XPDUTL("DGMTDT","MAIN^DG311PIR",0)
+3 QUIT
MAIN ;Main Driver
+1 NEW DGRECNT,DGLY,DGMTPAR
+2 SET U="^"
SET DGRECNT=0
+3 DO BMES^XPDUTL(" Starting post-install process...")
+4 ;Last Year, required by PAR^DGMTSCU
SET DGLY=2990000
+5 DO PAR^DGMTSCU
+6 DO LOOP
+7 ; Clean up any invalid '0' pointers to Patient Relation
DO MAIN^DG311PTR
+8 DO BMES^XPDUTL(" Post-install process has completed.")
+9 DO BMES^XPDUTL(" "_DGRECNT_" total records have been identified and corrected.")
+10 QUIT
LOOP ; Locate and correct incorrect TOTAL DEPENDENTS field
+1 NEW DGMTDT,DGIEN31,DGNOD31,DGIEN2,DGSTA,DGTOTD,DGMTYPT,DGDEPC,DGPAY,DGDEC
+2 NEW DGHARD
+3 ;Patch DG*5.3*291 release date
SET DGMTDT=3000705
+4 IF $DATA(XPDNM)
SET DGMTDT=+$$PARCP^XPDUTL("DGMTDT")
+5 if (DGMTDT<3000705)
SET DGMTDT=3000705
+6 FOR
SET DGMTDT=$ORDER(^DGMT(408.31,"B",DGMTDT))
if 'DGMTDT
QUIT
Begin DoDot:1
+7 SET DGIEN31=0
+8 FOR
SET DGIEN31=$ORDER(^DGMT(408.31,"B",DGMTDT,DGIEN31))
if 'DGIEN31
QUIT
Begin DoDot:2
+9 SET DGNOD31=$GET(^DGMT(408.31,DGIEN31,0))
+10 SET DGIEN2=$PIECE(DGNOD31,"^",2)
if 'DGIEN2
QUIT
+11 ;Means Test Status
SET DGSTA=$PIECE(DGNOD31,"^",3)
+12 ;Type of Test: 1=Means Test 2=Copay Test
SET DGMTYPT=$PIECE(DGNOD31,"^",19)
+13 ;Total Dependents
SET DGTOTD=$PIECE(DGNOD31,"^",18)
+14 ;Agreed To Pay Deductible
SET DGPAY=$PIECE(DGNOD31,"^",11)
+15 ;Declines To Give Income Info.
SET DGDEC=$PIECE(DGNOD31,"^",14)
+16 ;Hardship?
SET DGHARD=$PIECE(DGNOD31,"^",20)
+17 ; Recalculate Total Dependents minus spouse
DO GETREL^DGMTU11(DGIEN2,"VSC",DGMTDT,DGIEN31)
+18 SET DGDEPC=DGDEP
+19 ; Include the spouse as DGMTU11 only returns children
if $GET(DGREL("S"))
SET DGDEPC=DGDEPC+1
+20 IF (DGTOTD!DGDEPC)&(DGTOTD'=DGDEPC)
DO UPDATE
+21 ; Update Checkpoint
IF $DATA(XPDNM)
SET %=$$UPCP^XPDUTL("DGMTDT",DGMTDT)
End DoDot:2
End DoDot:1
+22 QUIT
UPDATE ;Update .18 field of ANNUAL MEANS TEST file
+1 NEW DATA,DGENDA,ERROR,DFN,DGMTI,DGVIRI,DGVINI,DGMTACT,DGMTI,DGMTINF,DGREL,DGPRIEN,DGUPSW
+2 SET DFN=DGIEN2
SET DGMTI=DGIEN31
SET (DGVIRI,DGREL,DGUPSW)=""
+3 FOR
if (DGREL'=1)
SET DGVIRI=$ORDER(^DGMT(408.22,"B",DFN,DGVIRI),-1)
if DGREL=1!('DGVIRI)
QUIT
Begin DoDot:1
+4 SET DGVINI=$PIECE($GET(^DGMT(408.22,DGVIRI,0)),U,2)
+5 if 'DGVINI
QUIT
+6 ; Pointer to PATIENT RELATION file (#408.12)
SET DGPRIEN=$PIECE($GET(^DGMT(408.21,DGVINI,0)),U,2)
+7 if 'DGPRIEN
QUIT
+8 ;Pointer to RELATIONSHIP file (#408.11)
SET DGREL=$PIECE($GET(^DGPR(408.12,DGPRIEN,0)),U,2)
+9 IF DGREL=1
SET DATA(.13)=DGDEP
SET DGENDA=DGVIRI
SET ERROR=""
Begin DoDot:2
+10 IF $$UPD^DGENDBS(408.22,.DGENDA,.DATA,.ERROR)
QUIT
End DoDot:2
End DoDot:1
+11 ; Quit if relationship is not 'SELF'
if DGREL'=1
QUIT
+12 ;only make call if current status is 'Cat A'. Or, if copay test, only make call for status of 'Exempt'.
if (DGSTA=4)!(DGMTYPT=2&(DGSTA=7))
DO SET^DGMTSCU2
+13 KILL DATA
+14 ; Newly derived Total # of dependents
SET DATA(.18)=DGDEPC
+15 ; In the following 2 lines, only want to update Status and associated
+16 ; fields if current status is 'Cat A', and 'Hardship' flag is not 'YES'.
+17 ; For copay test, only update status and associated fields if current
+18 ; status is 'Exempt' and 'Hardship' flag is not 'YES'.
+19 IF (DGSTA=4)
IF 'DGHARD
SET DGUPSW=1
+20 IF DGMTYPT=2&(DGSTA=7)
IF 'DGHARD
SET DGUPSW=1
+21 IF DGUPSW
Begin DoDot:1
+22 ; Newly derived Status
SET DATA(.03)=DGMTS
+23 ; Newly derived Threshold A field
SET DATA(.12)=DGTHA
+24 ; Newly derived Test Determined Status
SET DATA(2.03)=DGMTS
End DoDot:1
+25 ; need DGMTS for build of ^XTMP
IF (DGSTA'=4)&(DGSTA'=7)
SET DGMTS=DGSTA
+26 SET DGENDA=DGIEN31
SET ERROR=""
+27 ; Needed for call to DGMTEVT
SET DGMTACT="EDT"
SET DGMTI=DGENDA
SET DGMTINF=1
+28 DO PRIOR^DGMTEVT
+29 IF $$UPD^DGENDBS(408.31,.DGENDA,.DATA,.ERROR)
Begin DoDot:1
+30 DO AFTER^DGMTEVT
+31 ; Call to Means Test Event Driver
DO EN^DGMTEVT
+32 SET DGRECNT=DGRECNT+1
+33 DO BUILDLN
+34 DO ATRXREF
End DoDot:1
+35 QUIT
+36 ;
BUILDLN ; Build storage array with data
+1 ;
+2 ;Output:
+3 ; ^XTMP("DG311PIR",pt name,pt ssn,income year,old status,new status)=""
+4 ;
+5 NEW DGNAME,DGSSN,DGINY
+6 ;
+7 ; - pt name and ssn from Patient (#2) file
+8 SET DGNAME=$PIECE($GET(^DPT(DFN,0)),"^")
SET DGSSN=$PIECE($GET(^(.36)),"^",3)
+9 if DGNAME=""
SET DGNAME=DFN
+10 if DGSSN=""
SET DGSSN="MISSING"
+11 SET Y=DGMTDT
+12 DO DD^%DT
+13 SET DGINY=$PIECE(Y," ",3)
+14 ;
+15 SET ^XTMP("DG311PIR",DGNAME,DGSSN,DGINY,DGSTA,DGMTS)=""
+16 QUIT
+17 ;
ATRXREF ; Add entry into the 'ATR' cross reference of the IVM PATIENT (#301.5)
+1 ; file so that demographic and income information will be transmitted
+2 ; to the IVM Center.
+3 ;
+4 NEW IVIEN,IVNOD,IVIY,IVLAST,IVSF,IVTS
+5 SET IVIEN=""
SET IVLAST=0
SET IVLIEN=""
+6 FOR
SET IVIEN=$ORDER(^IVM(301.5,"B",DGIEN2,IVIEN))
if 'IVIEN
QUIT
Begin DoDot:1
+7 SET IVNOD=^IVM(301.5,IVIEN,0)
+8 SET IVIY=$PIECE(IVNOD,U,2)
+9 if (IVIY>IVLAST)
SET IVLAST=IVIY
SET IVLIEN=IVIEN
End DoDot:1
+10 IF (IVLIEN'="")
Begin DoDot:1
+11 SET ^IVM(301.5,"ATR",0,IVLIEN)=""
+12 ; Transmission Status Flag
SET IVTS=$PIECE(IVNOD,U,3)
+13 ; Stop Flag
SET IVSF=$PIECE(IVNOD,U,4)
+14 IF IVTS!IVSF
Begin DoDot:2
+15 KILL DATA
+16 SET DATA(.03)=0
SET DATA(.04)=0
SET ERROR=""
+17 IF $$UPD^DGENDBS(301.5,.IVLIEN,.DATA,.ERROR)
QUIT
End DoDot:2
End DoDot:1
+18 QUIT
