DGMTU2 ;ALB/RMO - Income Utilities ; 6/18/09 6:48pm
;;5.3;Registration;**33,688,805**;Aug 13, 1993;Build 4
;
GETIENS(DFN,DGPRI,DGDT) ;Look-up individual annual income and income relation
; Input -- DFN Patient file IEN
; DGPRI Patient Relation IEN
; DGDT Date/Time
; Output -- DGINI Individual Annual Income IEN
; DGIRI Income Relation IEN
; DGERR 1=ERROR and 0=NO ERROR
S DGERR=0
S DGINI=$$GETIN(DFN,DGPRI,DGDT) S:DGINI<0 DGERR=1
I 'DGERR S DGIRI=$$GETIR(DFN,DGINI) S:DGIRI<0 DGERR=1
Q
;
GETIN(DFN,DGPRI,DGDT) ;Look-up individual annual income
; Add a new entry if one is not found
; Input -- DFN Patient file IEN
; DGPRI Patient Relation IEN
; DGDT Date/Time
; Output -- Individual Annual Income IEN
N DGINI,DGLY
S DGLY=$$LYR^DGMTSCU1(DGDT)
S DGINI=+$$IAI^DGMTU3(DGPRI,DGLY)
I '$D(^DGMT(408.21,DGINI,0)) S DGINI=$$ADDIN(DFN,DGPRI,DGLY)
GETINQ Q $S(DGINI>0:DGINI,1:-1)
;
ADDIN(DFN,DGPRI,DGLY) ;Add a new individual annual income entry
; Input -- DFN Patient file IEN
; DGPRI Patient Relation IEN
; DGLY Last Year
; Output -- New Individual Annual Income IEN
N DA,DD,DGINI,DGNOW,DIC,DIK,DINUM,DLAYGO,DO,X,Y,%
D NOW^%DTC S DGNOW=%
S X=DGLY,(DIC,DIK)="^DGMT(408.21,",DIC(0)="L",DLAYGO=408.21
S DIC("DR")=".02////"_DGPRI_";101////"_DUZ_";102////"_DGNOW
D FILE^DICN S DGINI=+Y
ADDINQ Q $S(DGINI>0:DGINI,1:-1)
;
GETIR(DFN,DGINI) ;Look-up income relation
; Add a new entry if one is not found
; Input -- DFN Patient file IEN
; DGINI Individual Annual Income IEN
; Output -- Income Relation IEN
N DGIRI
S DGIRI=+$O(^DGMT(408.22,"AIND",DGINI,0))
I '$D(^DGMT(408.22,DGIRI,0)) S DGIRI=$$ADDIR(DFN,DGINI)
GETIRQ Q $S(DGIRI>0:DGIRI,1:-1)
;
ADDIR(DFN,DGINI) ;Add a new income relation entry
; Input -- DFN Patient file IEN
; DGINI Individual Annual Income IEN
; Output -- New Income Relation IEN
N DA,DD,DGIRI,DIC,DIK,DINUM,DLAYGO,DO,X,Y
S X=DFN,(DIC,DIK)="^DGMT(408.22,",DIC(0)="L",DLAYGO=408.22
S DIC("DR")=".02////"_DGINI
D FILE^DICN S DGIRI=+Y
ADDIRQ Q $S(DGIRI>0:DGIRI,1:-1)
;
; GTS - DG*5.3*688
VRCHKUP(DGMTYPT,TYPE,DGOLDDT,DGNWDT) ;Check the version and convert IAI records, as needed
; Input -- DGMTYPT : Type of test being processed
; TYPE : Optional - used when called from COPYRX^DGMTR1
; to indicate existing MT or LTC
; DGOLDDT : Optional - Date of Test for Old MT/CP test
; DGNWDT : Optional - Date of Test for New MT/CP test
; Output -- CONVRTD : 1 - IAI Records converted
; : 0 - IAI Records not converted
;
N CONVRTD,DGMTLST,DGOTHIEN,DGSAMEYR,DGDEC31D,DGERR,DGMTRT,DGMTRT2
S CONVRTD=0
S DGSAMEYR=0
;
I +$G(DGOLDDT)=0 S DGOLDDT=DT ;When DGOLDDT is not defined, default today's date
I +$G(DGNWDT)'=0 S:($E(DGOLDDT,1,3)=$E(DGNWDT,1,3)) DGSAMEYR=1 ;If have New and Old test dates, check for same yr
S DGDEC31D=$E(DGOLDDT,1,3)_"1231" ;Set search date of Dec 31 of Old Test year
;
; Check type of test being added or edited and then check for another test in the current year
; If Same year, get new test
I DGSAMEYR DO
.; NOTE: MT can not be created from a LTC CP Exempt test
.I DGMTYPT=1 DO
. . S DGMTLST=$$LST^DGMTU(DFN,DGNWDT,2) ;Find existing CP test - MT required
. . S:($E($P(DGMTLST,"^",2),1,3)'=$E(DGOLDDT,1,3)) DGMTLST=$$LSTNP^DGMTU21(DFN,DGNWDT,2) ; Last primary test is previous YR
. ; When updating CP test find either MT or LTC CP Exemption test
.I DGMTYPT=2 DO
. . IF '$D(TYPE) S DGMTLST=$$LST^DGMTU(DFN,DGNWDT,1) ;Find existing MT test - CP required
. . IF $D(TYPE) S DGMTLST=$$LST^DGMTU(DFN,DGNWDT,TYPE) ;Find existing MT or LTC - CP Exempt
.I DGMTYPT=4 DO
. . IF '$D(TYPE) S DGMTLST=$$LST^DGMTU(DFN,DGNWDT,1) ;Find existing MT test - CP required
. . IF $D(TYPE) S DGMTLST=$$LST^DGMTU(DFN,DGNWDT,TYPE) ;Find existing MT - CP req.
. . ; If Last primary test is previous YR, look for last [may not be primary] (to check current year)
. . I $E($P(DGMTLST,"^",2),1,3)'=$E(DGOLDDT,1,3) DO
. . . S:'$D(TYPE) DGMTLST=$$LSTNP^DGMTU21(DFN,DGNWDT,1)
. . . S:$D(TYPE) DGMTLST=$$LSTNP^DGMTU21(DFN,DGNWDT,TYPE)
;If not same year, search for new test in old test year
I 'DGSAMEYR DO
.; NOTE: MT can not be created from a LTC CP Exempt test
.I DGMTYPT=1 DO
. . S DGMTLST=$$LST^DGMTU(DFN,DGDEC31D,2) ;Find existing CP test - MT required
.; When updating CP test find either MT or LTC CP Exemption test
.I DGMTYPT=2 DO
. . IF '$D(TYPE) S DGMTLST=$$LST^DGMTU(DFN,DGDEC31D,1) ;Find existing MT test - CP required
. . IF $D(TYPE) S DGMTLST=$$LST^DGMTU(DFN,DGDEC31D,TYPE) ;Find existing MT or LTC - CP Exempt
.I DGMTYPT=4 DO
. . IF '$D(TYPE) S DGMTLST=$$LST^DGMTU(DFN,DGDEC31D,1) ;Find existing MT test - CP required
. . IF $D(TYPE) S DGMTLST=$$LST^DGMTU(DFN,DGDEC31D,TYPE) ;Find existing MT test - CP req.
. . ; If Last primary test is previous YR, look for last [may not be primary] (to check current year)
. . I $E($P(DGMTLST,"^",2),1,3)'=$E(DGOLDDT,1,3) DO
. . . S:'$D(TYPE) DGMTLST=$$LSTNP^DGMTU21(DFN,DGDEC31D,1)
. . . S:$D(TYPE) DGMTLST=$$LSTNP^DGMTU21(DFN,DGDEC31D,TYPE)
;
; LTC4 test does not require a record in 408.31, 408.21 records can exist without MT/CP records
; If 408.31 entry is not found and LTC4 is being added
I (+$G(DGMTLST)'>0),(+DGMTYPT=4) DO
. N DGINC2,DGREL2,DGINR2,DGDEP2
. M:$D(DGINC) DGINC2=DGINC
. M:$D(DGREL) DGREL2=DGREL
. M:$D(DGINR) DGINR2=DGINR
. M:$D(DGDEP) DGDEP2=DGDEP
. ; Search IAI records in 408.21; If found convert to 1, as necessary
. D ALL^DGMTU21(DFN,"VSD",DT,"IPR")
. I $D(DGINC) DO
. . N OTHRTST
. . D ISCNVRT^DGMTUTL(.DGINC)
. . S OTHRTST=$$UPDTTSTS^DGMTU21(DFN,$E($P(DGMTLST,"^",2),1,3))
. . S CONVRTD=1
. ; Restore DGINC, DGREL, DGINR, and DGDEP
. K DGINC,DGREL,DGINR,DGDEP
. M:$D(DGINC2) DGINC=DGINC2
. M:$D(DGREL2) DGREL=DGREL2
. M:$D(DGINR2) DGINR=DGINR2
. M:$D(DGDEP2) DGDEP=DGDEP2
;
; If another test is found
I $D(DGMTLST),(+DGMTLST>0) DO
. ; if the year of the test that have = year of test with IAI records to analyze
. I ($E($P(DGMTLST,"^",2),1,3)=$E(DGOLDDT,1,3)) DO
. . S DGOTHIEN=+DGMTLST
. . ;
. . ; If the other test was not entered in Version 1 format
. . I +$P($G(^DGMT(408.31,DGOTHIEN,2)),"^",11)'=1 DO
. . . ; Save values of DGINC, DGREL, DGINR, and DGDEP
. . . N DGINC2,DGREL2,DGINR2,DGDEP2
. . . M:$D(DGINC) DGINC2=DGINC
. . . M:$D(DGREL) DGREL2=DGREL
. . . M:$D(DGINR) DGINR2=DGINR
. . . M:$D(DGDEP) DGDEP2=DGDEP
. . . ;
. . . ; Get IAI records from 408.21 and convert them from version 0 to 1
. . . D:(+$P(DGMTLST,"^",2)>0) ALL^DGMTU21(DFN,"VSD",+$P(DGMTLST,"^",2),"IPR")
. . . D:(+$P(DGMTLST,"^",2)'>0) ALL^DGMTU21(DFN,"VSD",DT,"IPR")
. . . D ISCNVRT^DGMTUTL(.DGINC)
. . . ;
. . . ; Update 2.11 in all (1, 2 and 4 type) 408.31 records for DFN and IY
. . . N OTHRTST
. . . S OTHRTST=$$UPDTTSTS^DGMTU21(DFN,$E($P(DGMTLST,"^",2),1,3))
. . . ;
. . . ; Restore DGINC, DGREL, DGINR, and DGDEP
. . . K DGINC,DGREL,DGINR,DGDEP
. . . M:$D(DGINC2) DGINC=DGINC2
. . . M:$D(DGREL2) DGREL=DGREL2
. . . M:$D(DGINR2) DGINR=DGINR2
. . . M:$D(DGDEP2) DGDEP=DGDEP2
. . . S CONVRTD=1
VRCHKQ Q CONVRTD
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGMTU2 7748 printed Oct 16, 2024@18:46:13 Page 2
DGMTU2 ;ALB/RMO - Income Utilities ; 6/18/09 6:48pm
+1 ;;5.3;Registration;**33,688,805**;Aug 13, 1993;Build 4
+2 ;
GETIENS(DFN,DGPRI,DGDT) ;Look-up individual annual income and income relation
+1 ; Input -- DFN Patient file IEN
+2 ; DGPRI Patient Relation IEN
+3 ; DGDT Date/Time
+4 ; Output -- DGINI Individual Annual Income IEN
+5 ; DGIRI Income Relation IEN
+6 ; DGERR 1=ERROR and 0=NO ERROR
+7 SET DGERR=0
+8 SET DGINI=$$GETIN(DFN,DGPRI,DGDT)
if DGINI<0
SET DGERR=1
+9 IF 'DGERR
SET DGIRI=$$GETIR(DFN,DGINI)
if DGIRI<0
SET DGERR=1
+10 QUIT
+11 ;
GETIN(DFN,DGPRI,DGDT) ;Look-up individual annual income
+1 ; Add a new entry if one is not found
+2 ; Input -- DFN Patient file IEN
+3 ; DGPRI Patient Relation IEN
+4 ; DGDT Date/Time
+5 ; Output -- Individual Annual Income IEN
+6 NEW DGINI,DGLY
+7 SET DGLY=$$LYR^DGMTSCU1(DGDT)
+8 SET DGINI=+$$IAI^DGMTU3(DGPRI,DGLY)
+9 IF '$DATA(^DGMT(408.21,DGINI,0))
SET DGINI=$$ADDIN(DFN,DGPRI,DGLY)
GETINQ QUIT $SELECT(DGINI>0:DGINI,1:-1)
+1 ;
ADDIN(DFN,DGPRI,DGLY) ;Add a new individual annual income entry
+1 ; Input -- DFN Patient file IEN
+2 ; DGPRI Patient Relation IEN
+3 ; DGLY Last Year
+4 ; Output -- New Individual Annual Income IEN
+5 NEW DA,DD,DGINI,DGNOW,DIC,DIK,DINUM,DLAYGO,DO,X,Y,%
+6 DO NOW^%DTC
SET DGNOW=%
+7 SET X=DGLY
SET (DIC,DIK)="^DGMT(408.21,"
SET DIC(0)="L"
SET DLAYGO=408.21
+8 SET DIC("DR")=".02////"_DGPRI_";101////"_DUZ_";102////"_DGNOW
+9 DO FILE^DICN
SET DGINI=+Y
ADDINQ QUIT $SELECT(DGINI>0:DGINI,1:-1)
+1 ;
GETIR(DFN,DGINI) ;Look-up income relation
+1 ; Add a new entry if one is not found
+2 ; Input -- DFN Patient file IEN
+3 ; DGINI Individual Annual Income IEN
+4 ; Output -- Income Relation IEN
+5 NEW DGIRI
+6 SET DGIRI=+$ORDER(^DGMT(408.22,"AIND",DGINI,0))
+7 IF '$DATA(^DGMT(408.22,DGIRI,0))
SET DGIRI=$$ADDIR(DFN,DGINI)
GETIRQ QUIT $SELECT(DGIRI>0:DGIRI,1:-1)
+1 ;
ADDIR(DFN,DGINI) ;Add a new income relation entry
+1 ; Input -- DFN Patient file IEN
+2 ; DGINI Individual Annual Income IEN
+3 ; Output -- New Income Relation IEN
+4 NEW DA,DD,DGIRI,DIC,DIK,DINUM,DLAYGO,DO,X,Y
+5 SET X=DFN
SET (DIC,DIK)="^DGMT(408.22,"
SET DIC(0)="L"
SET DLAYGO=408.22
+6 SET DIC("DR")=".02////"_DGINI
+7 DO FILE^DICN
SET DGIRI=+Y
ADDIRQ QUIT $SELECT(DGIRI>0:DGIRI,1:-1)
+1 ;
+2 ; GTS - DG*5.3*688
VRCHKUP(DGMTYPT,TYPE,DGOLDDT,DGNWDT) ;Check the version and convert IAI records, as needed
+1 ; Input -- DGMTYPT : Type of test being processed
+2 ; TYPE : Optional - used when called from COPYRX^DGMTR1
+3 ; to indicate existing MT or LTC
+4 ; DGOLDDT : Optional - Date of Test for Old MT/CP test
+5 ; DGNWDT : Optional - Date of Test for New MT/CP test
+6 ; Output -- CONVRTD : 1 - IAI Records converted
+7 ; : 0 - IAI Records not converted
+8 ;
+9 NEW CONVRTD,DGMTLST,DGOTHIEN,DGSAMEYR,DGDEC31D,DGERR,DGMTRT,DGMTRT2
+10 SET CONVRTD=0
+11 SET DGSAMEYR=0
+12 ;
+13 ;When DGOLDDT is not defined, default today's date
IF +$GET(DGOLDDT)=0
SET DGOLDDT=DT
+14 ;If have New and Old test dates, check for same yr
IF +$GET(DGNWDT)'=0
if ($EXTRACT(DGOLDDT,1,3)=$EXTRACT(DGNWDT,1,3))
SET DGSAMEYR=1
+15 ;Set search date of Dec 31 of Old Test year
SET DGDEC31D=$EXTRACT(DGOLDDT,1,3)_"1231"
+16 ;
+17 ; Check type of test being added or edited and then check for another test in the current year
+18 ; If Same year, get new test
+19 IF DGSAMEYR
Begin DoDot:1
+20 ; NOTE: MT can not be created from a LTC CP Exempt test
+21 IF DGMTYPT=1
Begin DoDot:2
+22 ;Find existing CP test - MT required
SET DGMTLST=$$LST^DGMTU(DFN,DGNWDT,2)
+23 ; Last primary test is previous YR
if ($EXTRACT($PIECE(DGMTLST,"^",2),1,3)'=$EXTRACT(DGOLDDT,1,3))
SET DGMTLST=$$LSTNP^DGMTU21(DFN,DGNWDT,2)
End DoDot:2
+24 ; When updating CP test find either MT or LTC CP Exemption test
+25 IF DGMTYPT=2
Begin DoDot:2
+26 ;Find existing MT test - CP required
IF '$DATA(TYPE)
SET DGMTLST=$$LST^DGMTU(DFN,DGNWDT,1)
+27 ;Find existing MT or LTC - CP Exempt
IF $DATA(TYPE)
SET DGMTLST=$$LST^DGMTU(DFN,DGNWDT,TYPE)
End DoDot:2
+28 IF DGMTYPT=4
Begin DoDot:2
+29 ;Find existing MT test - CP required
IF '$DATA(TYPE)
SET DGMTLST=$$LST^DGMTU(DFN,DGNWDT,1)
+30 ;Find existing MT - CP req.
IF $DATA(TYPE)
SET DGMTLST=$$LST^DGMTU(DFN,DGNWDT,TYPE)
+31 ; If Last primary test is previous YR, look for last [may not be primary] (to check current year)
+32 IF $EXTRACT($PIECE(DGMTLST,"^",2),1,3)'=$EXTRACT(DGOLDDT,1,3)
Begin DoDot:3
+33 if '$DATA(TYPE)
SET DGMTLST=$$LSTNP^DGMTU21(DFN,DGNWDT,1)
+34 if $DATA(TYPE)
SET DGMTLST=$$LSTNP^DGMTU21(DFN,DGNWDT,TYPE)
End DoDot:3
End DoDot:2
End DoDot:1
+35 ;If not same year, search for new test in old test year
+36 IF 'DGSAMEYR
Begin DoDot:1
+37 ; NOTE: MT can not be created from a LTC CP Exempt test
+38 IF DGMTYPT=1
Begin DoDot:2
+39 ;Find existing CP test - MT required
SET DGMTLST=$$LST^DGMTU(DFN,DGDEC31D,2)
End DoDot:2
+40 ; When updating CP test find either MT or LTC CP Exemption test
+41 IF DGMTYPT=2
Begin DoDot:2
+42 ;Find existing MT test - CP required
IF '$DATA(TYPE)
SET DGMTLST=$$LST^DGMTU(DFN,DGDEC31D,1)
+43 ;Find existing MT or LTC - CP Exempt
IF $DATA(TYPE)
SET DGMTLST=$$LST^DGMTU(DFN,DGDEC31D,TYPE)
End DoDot:2
+44 IF DGMTYPT=4
Begin DoDot:2
+45 ;Find existing MT test - CP required
IF '$DATA(TYPE)
SET DGMTLST=$$LST^DGMTU(DFN,DGDEC31D,1)
+46 ;Find existing MT test - CP req.
IF $DATA(TYPE)
SET DGMTLST=$$LST^DGMTU(DFN,DGDEC31D,TYPE)
+47 ; If Last primary test is previous YR, look for last [may not be primary] (to check current year)
+48 IF $EXTRACT($PIECE(DGMTLST,"^",2),1,3)'=$EXTRACT(DGOLDDT,1,3)
Begin DoDot:3
+49 if '$DATA(TYPE)
SET DGMTLST=$$LSTNP^DGMTU21(DFN,DGDEC31D,1)
+50 if $DATA(TYPE)
SET DGMTLST=$$LSTNP^DGMTU21(DFN,DGDEC31D,TYPE)
End DoDot:3
End DoDot:2
End DoDot:1
+51 ;
+52 ; LTC4 test does not require a record in 408.31, 408.21 records can exist without MT/CP records
+53 ; If 408.31 entry is not found and LTC4 is being added
+54 IF (+$GET(DGMTLST)'>0)
IF (+DGMTYPT=4)
Begin DoDot:1
+55 NEW DGINC2,DGREL2,DGINR2,DGDEP2
+56 if $DATA(DGINC)
MERGE DGINC2=DGINC
+57 if $DATA(DGREL)
MERGE DGREL2=DGREL
+58 if $DATA(DGINR)
MERGE DGINR2=DGINR
+59 if $DATA(DGDEP)
MERGE DGDEP2=DGDEP
+60 ; Search IAI records in 408.21; If found convert to 1, as necessary
+61 DO ALL^DGMTU21(DFN,"VSD",DT,"IPR")
+62 IF $DATA(DGINC)
Begin DoDot:2
+63 NEW OTHRTST
+64 DO ISCNVRT^DGMTUTL(.DGINC)
+65 SET OTHRTST=$$UPDTTSTS^DGMTU21(DFN,$EXTRACT($PIECE(DGMTLST,"^",2),1,3))
+66 SET CONVRTD=1
End DoDot:2
+67 ; Restore DGINC, DGREL, DGINR, and DGDEP
+68 KILL DGINC,DGREL,DGINR,DGDEP
+69 if $DATA(DGINC2)
MERGE DGINC=DGINC2
+70 if $DATA(DGREL2)
MERGE DGREL=DGREL2
+71 if $DATA(DGINR2)
MERGE DGINR=DGINR2
+72 if $DATA(DGDEP2)
MERGE DGDEP=DGDEP2
End DoDot:1
+73 ;
+74 ; If another test is found
+75 IF $DATA(DGMTLST)
IF (+DGMTLST>0)
Begin DoDot:1
+76 ; if the year of the test that have = year of test with IAI records to analyze
+77 IF ($EXTRACT($PIECE(DGMTLST,"^",2),1,3)=$EXTRACT(DGOLDDT,1,3))
Begin DoDot:2
+78 SET DGOTHIEN=+DGMTLST
+79 ;
+80 ; If the other test was not entered in Version 1 format
+81 IF +$PIECE($GET(^DGMT(408.31,DGOTHIEN,2)),"^",11)'=1
Begin DoDot:3
+82 ; Save values of DGINC, DGREL, DGINR, and DGDEP
+83 NEW DGINC2,DGREL2,DGINR2,DGDEP2
+84 if $DATA(DGINC)
MERGE DGINC2=DGINC
+85 if $DATA(DGREL)
MERGE DGREL2=DGREL
+86 if $DATA(DGINR)
MERGE DGINR2=DGINR
+87 if $DATA(DGDEP)
MERGE DGDEP2=DGDEP
+88 ;
+89 ; Get IAI records from 408.21 and convert them from version 0 to 1
+90 if (+$PIECE(DGMTLST,"^",2)>0)
DO ALL^DGMTU21(DFN,"VSD",+$PIECE(DGMTLST,"^",2),"IPR")
+91 if (+$PIECE(DGMTLST,"^",2)'>0)
DO ALL^DGMTU21(DFN,"VSD",DT,"IPR")
+92 DO ISCNVRT^DGMTUTL(.DGINC)
+93 ;
+94 ; Update 2.11 in all (1, 2 and 4 type) 408.31 records for DFN and IY
+95 NEW OTHRTST
+96 SET OTHRTST=$$UPDTTSTS^DGMTU21(DFN,$EXTRACT($PIECE(DGMTLST,"^",2),1,3))
+97 ;
+98 ; Restore DGINC, DGREL, DGINR, and DGDEP
+99 KILL DGINC,DGREL,DGINR,DGDEP
+100 if $DATA(DGINC2)
MERGE DGINC=DGINC2
+101 if $DATA(DGREL2)
MERGE DGREL=DGREL2
+102 if $DATA(DGINR2)
MERGE DGINR=DGINR2
+103 if $DATA(DGDEP2)
MERGE DGDEP=DGDEP2
+104 SET CONVRTD=1
End DoDot:3
End DoDot:2
End DoDot:1
VRCHKQ QUIT CONVRTD
