IVMUM8 ;ALB/SEK - DELETE IVM MEANS TEST (CON'T) ; 13 JAN 94
;;2.0;INCOME VERIFICATION MATCH;**1,17**;21-OCT-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
EN ; change demo data in 408.12 & 408.13 back to VAMC values
; ivm12 408.12 ien
; ivm13 408.13 ien
; ivmmtien 408.31 ien
;
; note: 408.13 fields were added to 408.41 before 408.12 field
;
K DR S IVM41=0
F S IVM41=$O(^DGMT(408.41,"D",IVMMTIEN,IVM41)) Q:'IVM41 D
.S IVM411=$G(^DGMT(408.41,+IVM41,0))
.Q:$P(IVM411,"^",10)'=IVM13
.S IVMOLD=$P(IVM411,"^",5)
.S IVMOLD=$S(IVMOLD="":"@",1:IVMOLD)
.S IVMFILE=$P(IVMAR1($P(IVM411,"^",2)),";")
.S IVMNOD=$P(IVMAR1($P(IVM411,"^",2)),";",2)
.I IVMFILE=408.13 S DA=IVM13,DIE="^DGPR(408.13,"
.I IVMFILE=408.12 S DA=IVM12,DIE="^DGPR(408.12,"
.S DR=IVMNOD_"////^S X=IVMOLD" D ^DIE K DA,DR,DIE
.Q
Q
;
EN1 ; change primary income test for year? code from 0 to 1 for VAMC MT
S DA=IVMVAMC,DIE="^DGMT(408.31,",DR="2////1" D ^DIE K DA,DIE,DR
;
; delete 408.31
;
S DA=IVMMTIEN,DIK="^DGMT(408.31," D ^DIK
;
; open IVM case record which was closed during upload
S DA=$O(^IVM(301.5,"APT",+DFN,+DGLY,0))
I $G(^IVM(301.5,+DA,0))']"" G MTBULL
S DR=".04////0",DIE="^IVM(301.5," D ^DIE
K ^IVM(301.5,DA,1)
;
MTBULL ; build and transmit mail message to IVM mail group notifying site
; that a means test was deleted.
S IVMPAT=$$PT^IVMUFNC4(DFN)
S XMSUB="IVM - MEANS TEST DELETED"
S IVMTEXT(1)="An Income Verification Match Means Test was deleted for the"
S IVMTEXT(2)="following patient:"
S IVMTEXT(3)=" "
S IVMTEXT(4)=" NAME: "_$P(IVMPAT,"^")
S IVMTEXT(5)=" ID: "_$P(IVMPAT,"^",2)
S Y=IVMMTDT X ^DD("DD")
S IVMTEXT(6)=" DATE OF TEST: "_Y
S IVMTEXT(7)=" "
S IVMTEXT(8)="NOTE: The original DHCP Means Test is now the primary Means Test."
D MAIL^IVMUFNC()
;
; call event driver
S DGMTINF=1,DGMTP=IVMNO,DGMTA=IVMVNO
S DGMTACT="DUP",DGMTI=IVMVAMC D EN^DGMTEVT
S DGMTACT="DEL",DGMTI=IVMMTIEN D EN^DGMTEVT
;
; cleanup
K DA,DFN,DGINC,DGINR,DGLY,DGMTA,DGMTACT,DGMTI,DGMTINF,DGMTP
K DIE,DIK,DR,IVM12,IVM121,IVM13,IVM41,IVM411,IVMFILE
K IVMFLGC,IVMMTDT,IVMMTIEN,IVMN,IVMNO,IVMNOD,IVMOLD
K IVMPAT,IVMSOT,IVMTEXT,IVMVAMC,IVMVAMCA,IVMVNO,XMSUB,Y
Q
;
SETUPAR ; create array ivmar1
; subscript is 408.42 node (type of change - name, dob, ssn, sex, relationship)
; 1st piece is file 408.12 or 408.13
; 2nd piece is 408.12 or 408.13 field #
F IVM41=4:1 S IVM411=$P($T(TYPECH+IVM41),";;",2) Q:IVM411="QUIT" D
.S IVMAR1($P(IVM411,";"))=$P(IVM411,";",2,3)
K IVM41,IVM411
Q
;
TYPECH ; type of dependent changes 408.41/408.42
; 1st piece - 408.42 table file node
; 2nd piece - file (408.12/408.13)
; 3rd piece - 408.12/408.13 field
;;16;408.13;.01
;;17;408.13;.03
;;18;408.13;.09
;;19;408.13;.02
;;20;408.12;.02
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMUM8 2899 printed Oct 16, 2024@18:03:44 Page 2
IVMUM8 ;ALB/SEK - DELETE IVM MEANS TEST (CON'T) ; 13 JAN 94
+1 ;;2.0;INCOME VERIFICATION MATCH;**1,17**;21-OCT-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
EN ; change demo data in 408.12 & 408.13 back to VAMC values
+1 ; ivm12 408.12 ien
+2 ; ivm13 408.13 ien
+3 ; ivmmtien 408.31 ien
+4 ;
+5 ; note: 408.13 fields were added to 408.41 before 408.12 field
+6 ;
+7 KILL DR
SET IVM41=0
+8 FOR
SET IVM41=$ORDER(^DGMT(408.41,"D",IVMMTIEN,IVM41))
if 'IVM41
QUIT
Begin DoDot:1
+9 SET IVM411=$GET(^DGMT(408.41,+IVM41,0))
+10 if $PIECE(IVM411,"^",10)'=IVM13
QUIT
+11 SET IVMOLD=$PIECE(IVM411,"^",5)
+12 SET IVMOLD=$SELECT(IVMOLD="":"@",1:IVMOLD)
+13 SET IVMFILE=$PIECE(IVMAR1($PIECE(IVM411,"^",2)),";")
+14 SET IVMNOD=$PIECE(IVMAR1($PIECE(IVM411,"^",2)),";",2)
+15 IF IVMFILE=408.13
SET DA=IVM13
SET DIE="^DGPR(408.13,"
+16 IF IVMFILE=408.12
SET DA=IVM12
SET DIE="^DGPR(408.12,"
+17 SET DR=IVMNOD_"////^S X=IVMOLD"
DO ^DIE
KILL DA,DR,DIE
+18 QUIT
End DoDot:1
+19 QUIT
+20 ;
EN1 ; change primary income test for year? code from 0 to 1 for VAMC MT
+1 SET DA=IVMVAMC
SET DIE="^DGMT(408.31,"
SET DR="2////1"
DO ^DIE
KILL DA,DIE,DR
+2 ;
+3 ; delete 408.31
+4 ;
+5 SET DA=IVMMTIEN
SET DIK="^DGMT(408.31,"
DO ^DIK
+6 ;
+7 ; open IVM case record which was closed during upload
+8 SET DA=$ORDER(^IVM(301.5,"APT",+DFN,+DGLY,0))
+9 IF $GET(^IVM(301.5,+DA,0))']""
GOTO MTBULL
+10 SET DR=".04////0"
SET DIE="^IVM(301.5,"
DO ^DIE
+11 KILL ^IVM(301.5,DA,1)
+12 ;
MTBULL ; build and transmit mail message to IVM mail group notifying site
+1 ; that a means test was deleted.
+2 SET IVMPAT=$$PT^IVMUFNC4(DFN)
+3 SET XMSUB="IVM - MEANS TEST DELETED"
+4 SET IVMTEXT(1)="An Income Verification Match Means Test was deleted for the"
+5 SET IVMTEXT(2)="following patient:"
+6 SET IVMTEXT(3)=" "
+7 SET IVMTEXT(4)=" NAME: "_$PIECE(IVMPAT,"^")
+8 SET IVMTEXT(5)=" ID: "_$PIECE(IVMPAT,"^",2)
+9 SET Y=IVMMTDT
XECUTE ^DD("DD")
+10 SET IVMTEXT(6)=" DATE OF TEST: "_Y
+11 SET IVMTEXT(7)=" "
+12 SET IVMTEXT(8)="NOTE: The original DHCP Means Test is now the primary Means Test."
+13 DO MAIL^IVMUFNC()
+14 ;
+15 ; call event driver
+16 SET DGMTINF=1
SET DGMTP=IVMNO
SET DGMTA=IVMVNO
+17 SET DGMTACT="DUP"
SET DGMTI=IVMVAMC
DO EN^DGMTEVT
+18 SET DGMTACT="DEL"
SET DGMTI=IVMMTIEN
DO EN^DGMTEVT
+19 ;
+20 ; cleanup
+21 KILL DA,DFN,DGINC,DGINR,DGLY,DGMTA,DGMTACT,DGMTI,DGMTINF,DGMTP
+22 KILL DIE,DIK,DR,IVM12,IVM121,IVM13,IVM41,IVM411,IVMFILE
+23 KILL IVMFLGC,IVMMTDT,IVMMTIEN,IVMN,IVMNO,IVMNOD,IVMOLD
+24 KILL IVMPAT,IVMSOT,IVMTEXT,IVMVAMC,IVMVAMCA,IVMVNO,XMSUB,Y
+25 QUIT
+26 ;
SETUPAR ; create array ivmar1
+1 ; subscript is 408.42 node (type of change - name, dob, ssn, sex, relationship)
+2 ; 1st piece is file 408.12 or 408.13
+3 ; 2nd piece is 408.12 or 408.13 field #
+4 FOR IVM41=4:1
SET IVM411=$PIECE($TEXT(TYPECH+IVM41),";;",2)
if IVM411="QUIT"
QUIT
Begin DoDot:1
+5 SET IVMAR1($PIECE(IVM411,";"))=$PIECE(IVM411,";",2,3)
End DoDot:1
+6 KILL IVM41,IVM411
+7 QUIT
+8 ;
TYPECH ; type of dependent changes 408.41/408.42
+1 ; 1st piece - 408.42 table file node
+2 ; 2nd piece - file (408.12/408.13)
+3 ; 3rd piece - 408.12/408.13 field
+4 ;;16;408.13;.01
+5 ;;17;408.13;.03
+6 ;;18;408.13;.09
+7 ;;19;408.13;.02
+8 ;;20;408.12;.02
+9 ;;QUIT
