DG10 ;ALB/MRL,DAK,AEG,PHH,TMK,ASMR/JD-LOAD/EDIT PATIENT DATA ; 09/30/15 @ 08:34
;;5.3;Registration;**32,109,139,149,182,326,513,425,574,642,658,773,864,921,993,1040**;Aug 13, 1993;Build 15
;Per VHA Directive 2004-038, this routine should not be modified.
;
;Done for eHMP project: DG*5.3*921
;Added logic to trigger unsolicited updates for demographics that are not otherwise triggered
;by the TRIGGER x-ref. New code: Tags T, T59, and T60 and any references to those tags thereof.
START ;
D LO^DGUTL
I $G(DGPRFLG)=1,$G(DGPLOC)=1 D G Q:$G(DGRPOUT),A1
.; D EN^DGRPD,REG^IVMCQ($G(DFN))
. D EN^DGRPD
. Q:$G(DGRPOUT)
. D REG^IVMCQ($G(DFN))
. D HINQ
;
; DG*5.3*993; Remove the DLAYGO variable and the "L" from DIC(0) since adding records to the PATIENT file is not allowed in DG LOAD PATIENT DATA
A ;W !! K VET,DIE,DIC,CARD S DIC=2,DLAYGO=2,DIC(0)="ALEQM" K DIC("S") D ^DIC G Q:Y<0 S (DFN,DA)=+Y,DGNEW=$P(Y,"^",3) K DLAYGO
; DG*5.3*1040 - NEW variable DGTMOT and initialize to 0 to track timeout in address and DGADDRE to track the return value of $$ADD^DGADDUTL
N DGADDRE,DGTMOT S DGTMOT=0,DGADDRE=""
W !! K VET,DIE,DIC,CARD S DIC=2,DIC(0)="AEQM" K DIC("S") D ^DIC G Q:Y<0 S (DFN,DA)=+Y,DGNEW=$P(Y,"^",3) K DLAYGO
;DG*5.3*921 Invoke eHMP demographic change checking
I DGNEW']"" D T59(DFN,"BEFORE") ;Get a snapshot of the demographics before changes
N Y D PAUSE I DGNEW D NEW^DGRP S DA=DFN,VET=$S($D(^DPT(DFN,"VET")):^("VET")'="Y",1:0)
;
;MPI QUERY
;check to see if CIRN PD/MPI is installed
N X S X="MPIFAPI" X ^%ZOSF("TEST") G:'$T SKIP
K MPIFRTN
D MPIQ^MPIFAPI(DFN)
K MPIFRTN
;
N DGNOIVMUPD
S DGNOIVMUPD=1 ; Set flag to prevent MT Event Driver from updating converted IVM test
I +$G(DGNEW) D
. ; query CMOR for Patient Record Flag Assignments if NEW patient and
. ; display results
. I $$PRFQRY^DGPFAPI(DFN) D DISPPRF^DGPFAPI(DFN)
. I $$EN^DGPFMPI(DFN)
;
SKIP ;
;DG*5.3*921 Invoke eHMP demographic change checking (via D T)
S DGELVER=0 D EN^DGRPD I $D(DGRPOUT) K DGRPOUT D T G A
D HINQ,REG^IVMCQ($G(DFN)) G A1
;
HINQ ;
S Y=$S($D(^DG(43,1,0)):^(0),1:0) I $P(Y,U,27) S X="DVBHQZ4" X ^%ZOSF("TEST") I $T D
.N DGROUT
.S DGROUT=X
.I $G(DFN) D
..N X,Y,DGRP
..F X=.3,.32 S DGRP(X)=$G(^DPT(DFN,X))
..W !," Money Verified: " S Y=$P(DGRP(.3),"^",6) X:Y]"" ^DD("DD") W $S(Y]"":Y,1:"NOT VERIFIED")
..W ?40," Service Verified: " S Y=$P(DGRP(.32),"^",2) X:Y]"" ^DD("DD") W $S(Y]"":Y,1:"NOT VERIFIED")
.D @("EN^"_DGROUT) K Y Q ;from dgdem0
Q
;
; SDIEMM is used as a flag by AMBCARE Incomplete Encounter Management
; to bypass the embossing routines when calling load/edit from IEMM
;
; DG*5.3*1040 - If variable DGADDRE=-1, branch to RPOUT due to timeout; if DGRPOUT=1, branch to RPOUT as well
A1 D G:$G(DGADDRE)=-1 RPOUT G H:'%,CK:%'=1 S DGRPV=0 D EN1^DGRP G:+$G(DGRPOUT) RPOUT D MT(DFN),CP G Q:$G(DGPRFLG)=1 G Q:$G(SDIEMM) G Q:'$D(DA),EMBOS
.W !,"Do you want to ",$S(DGNEW:"enter",1:"edit")," Patient Data"
.S %=1 D YN^DICN
.I +$G(DGNEW) Q
.S DGADDRE=$$ADD^DGADDUTL($G(DFN)) ; DG*5.3*1040 - Store the return value in DGADDRE
;
H W !?5,"Enter 'YES' to enter/edit registration data or 'NO' to continue without",!?5,"editing."
G A1
;
; DG*5.3*1040 - Only do if there wasn't a timeout so branch to RPOUT
CK S DGEDCN=1 G:+$G(DGRPOUT) RPOUT D ^DGRPC,MT(DFN),CP
G Q:$G(DGPRFLG)=1 G Q:$G(SDIEMM)
I $G(DGER)[55 K DIR S DIR(0)="Y",DIR("A")="Do you wish to return to Screen #9 to enter missing Income Data? " D ^DIR K DIR
;G:Y ^DGRP9
;
EMBOS ;W ! D EMBOS^DGQEMA G A
;DG*5.3*921 Invoke eHMP demographic change checking
D T
G A
;
;
; DG*5.3*1040 - Clean variable DGTMOT
Q K X,Y,Z,DIC,DGELVER,DGNEW,DGRPV,DGTMOT,VET Q
;
MT(DFN) ; Check if user requires a means test. Ask user if they want to proceedif
; one is required
I '$D(SDIEMM) DO
.N DGREQF,DIV
.D EN^DGMTR
.I DGREQF D EDT^DGMTU(DFN,DT):$P($$MTS^DGMTU(DFN),U,2)="R"
.Q
I $D(SDIEMM) DO
.N DGMTI
.S DGMTI=$$LST^DGMTU(DFN,SCINF("ENCOUNTER"),1)
.I $P(DGMTI,U,4)="R" D I 1
..S DGMT0=$G(^DGMT(408.31,+DGMTI,0)),DGMTDT=$P(DGMT0,"^")
..I '$$OKTOCONT(DGMTDT) Q
..S DGMTI=+DGMTI,DGMTYPT=1,DGMTACT="COM",DGMTROU="COM^DGMTEO" D EN^DGMTSC
.E D WARNING
.Q
Q
;
WARNING ;
;prints a warning to the screen about means test
;
W !!,"A means test for this encounter date was not found and may be required!"
W !,"Further investigation will be needed."
W !
D PAUSE
Q
;
PAUSE ;
N DIR
S DIR(0)="FAO",DIR("A")="Press ENTER to continue " D ^DIR
Q
;
OKTOCONT(Y) ;
;
N DIR
W !!,"Patient Requires a means Test"
X ^DD("DD")
W !,"Primary Means Test Required from '",Y,"'",!
;
I $D(SDIEMM),'$D(^XUSEC("SCENI MEANS TEST EDIT",DUZ)) DO G OKQ
.W !,$C(7),"You do not have the appropriate IEMM Security Key. Contact your supervisor.",!
.D PAUSE
.S Y=0
;
S DIR("A")="Do you wish to proceed with the means test at this time"
S DIR("B")="YES"
S DIR(0)="Y"
D ^DIR
OKQ Q $S(Y=1:1,1:0)
;
CP ;If not (autoexempt or MTested) & no CP test this year then
;prompt for add/edit cp test
N DIV,DGIB,DGIBDT,DGX,X,DIRUT,DTOUT
G:'$P($G(^DG(43,1,0)),U,41) QTCP ;USE CP FLAG
S DGIBDT=$S($D(DFN1):9999999-DFN1,1:DT)
D EN^DGMTCOR
I +$G(DGNOCOPF) S DGMTCOR=0
I DGMTCOR D THRESH^DGMTCOU1(DGIBDT) D EDT^DGMTCOU(DFN,DT)
K DGNOCOPF
QTCP Q
;
T ;
;DG*5.3*921- Check to ensure all demographic changes are passed to eHMP 10/2/15
;If we are editing demographics for an existing patient, get a snapshot after
;the changes and compare the before and after snapshots. If there are ANY changes
;invoke the unsolicited update protocol.
I DGNEW']"" D
.N DGFIELD,DGFILE,DGDA
.D T59(DFN,"AFTER")
.I $$T60("BEFORE","AFTER",.DGFIELD) S DGFILE=2,DGDA=DFN D:$L($T(DG^HMPEVNT)) DG^HMPEVNT
Q
;
T59(A,B) ;Get all the demographics that are supposed to trigger an unsolicited update
;DG*5.3*921
;A = DFN
;B = Return array
N FLDS,INS
S FLDS=".01;.02;.03;.05;.08;.09;.351;.361;.364;.111;.1112;.112;.113;.114;.115;.131;.132;.134;"
S FLDS=FLDS_".211;.212;.213;.214;.216;.217;.218;.219;.301;.302;1901;.32102;.32103;.32201;.5295;"
S FLDS=FLDS_".133;.1211;.1212;.1213;.1214;.1215;.1216;.331;.332;.333;.334;.335;.336;.337;"
S FLDS=FLDS_".338;.339;.33011;.215;.21011;.3731;"
D GETS^DIQ(2,A_",",FLDS,,B)
Q
;
T60(A,B,C) ;Compare the before and after arrays to see if any of the considerd demographics
;were changed
;DG*5.3*921
;A = "before" changes array
;B = "after" changes array
;Both A and B are of the form: A(2,DFN_",",Field#)=Field value. E.g. A(2,"3,",.114)="LOS ANGELES"
;C = the first field that was changed (e.g. .111 for street address line 1).
; This is an output parameter.
;Returns true (1) if any change is detected. Quits at the FIRST find.
; false (null) if there are no changes.
N F,X,Y,Z
S (C,F,Z)=""
F S Z=$O(@A@(Z)) Q:$G(F)!(Z'=+Z) D
.S Y=""
.F S Y=$O(@A@(Z,Y)) Q:$G(F)!(Y']"") D
..S X=""
..F S X=$O(@A@(Z,Y,X)) Q:$G(F)!(X'=+X) D
...I @A@(Z,Y,X)'=$G(@B@(Z,Y,X)) S F=1,C=X Q
Q F
; DG*5.3*1040 - Entry point to quit and go to next select patient prompt
RPOUT ; Entry point if user timeout out
S DGRPOUT=""
G A
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG10 7261 printed Sep 23, 2025@20:10:52 Page 2
DG10 ;ALB/MRL,DAK,AEG,PHH,TMK,ASMR/JD-LOAD/EDIT PATIENT DATA ; 09/30/15 @ 08:34
+1 ;;5.3;Registration;**32,109,139,149,182,326,513,425,574,642,658,773,864,921,993,1040**;Aug 13, 1993;Build 15
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;Done for eHMP project: DG*5.3*921
+5 ;Added logic to trigger unsolicited updates for demographics that are not otherwise triggered
+6 ;by the TRIGGER x-ref. New code: Tags T, T59, and T60 and any references to those tags thereof.
START ;
+1 DO LO^DGUTL
+2 IF $GET(DGPRFLG)=1
IF $GET(DGPLOC)=1
Begin DoDot:1
+3 ; D EN^DGRPD,REG^IVMCQ($G(DFN))
+4 DO EN^DGRPD
+5 if $GET(DGRPOUT)
QUIT
+6 DO REG^IVMCQ($GET(DFN))
+7 DO HINQ
End DoDot:1
if $GET(DGRPOUT)
GOTO Q
GOTO A1
+8 ;
+9 ; DG*5.3*993; Remove the DLAYGO variable and the "L" from DIC(0) since adding records to the PATIENT file is not allowed in DG LOAD PATIENT DATA
A ;W !! K VET,DIE,DIC,CARD S DIC=2,DLAYGO=2,DIC(0)="ALEQM" K DIC("S") D ^DIC G Q:Y<0 S (DFN,DA)=+Y,DGNEW=$P(Y,"^",3) K DLAYGO
+1 ; DG*5.3*1040 - NEW variable DGTMOT and initialize to 0 to track timeout in address and DGADDRE to track the return value of $$ADD^DGADDUTL
+2 NEW DGADDRE,DGTMOT
SET DGTMOT=0
SET DGADDRE=""
+3 WRITE !!
KILL VET,DIE,DIC,CARD
SET DIC=2
SET DIC(0)="AEQM"
KILL DIC("S")
DO ^DIC
if Y<0
GOTO Q
SET (DFN,DA)=+Y
SET DGNEW=$PIECE(Y,"^",3)
KILL DLAYGO
+4 ;DG*5.3*921 Invoke eHMP demographic change checking
+5 ;Get a snapshot of the demographics before changes
IF DGNEW']""
DO T59(DFN,"BEFORE")
+6 NEW Y
DO PAUSE
IF DGNEW
DO NEW^DGRP
SET DA=DFN
SET VET=$SELECT($DATA(^DPT(DFN,"VET")):^("VET")'="Y",1:0)
+7 ;
+8 ;MPI QUERY
+9 ;check to see if CIRN PD/MPI is installed
+10 NEW X
SET X="MPIFAPI"
XECUTE ^%ZOSF("TEST")
if '$TEST
GOTO SKIP
+11 KILL MPIFRTN
+12 DO MPIQ^MPIFAPI(DFN)
+13 KILL MPIFRTN
+14 ;
+15 NEW DGNOIVMUPD
+16 ; Set flag to prevent MT Event Driver from updating converted IVM test
SET DGNOIVMUPD=1
+17 IF +$GET(DGNEW)
Begin DoDot:1
+18 ; query CMOR for Patient Record Flag Assignments if NEW patient and
+19 ; display results
+20 IF $$PRFQRY^DGPFAPI(DFN)
DO DISPPRF^DGPFAPI(DFN)
+21 IF $$EN^DGPFMPI(DFN)
End DoDot:1
+22 ;
SKIP ;
+1 ;DG*5.3*921 Invoke eHMP demographic change checking (via D T)
+2 SET DGELVER=0
DO EN^DGRPD
IF $DATA(DGRPOUT)
KILL DGRPOUT
DO T
GOTO A
+3 DO HINQ
DO REG^IVMCQ($GET(DFN))
GOTO A1
+4 ;
HINQ ;
+1 SET Y=$SELECT($DATA(^DG(43,1,0)):^(0),1:0)
IF $PIECE(Y,U,27)
SET X="DVBHQZ4"
XECUTE ^%ZOSF("TEST")
IF $TEST
Begin DoDot:1
+2 NEW DGROUT
+3 SET DGROUT=X
+4 IF $GET(DFN)
Begin DoDot:2
+5 NEW X,Y,DGRP
+6 FOR X=.3,.32
SET DGRP(X)=$GET(^DPT(DFN,X))
+7 WRITE !," Money Verified: "
SET Y=$PIECE(DGRP(.3),"^",6)
if Y]""
XECUTE ^DD("DD")
WRITE $SELECT(Y]"":Y,1:"NOT VERIFIED")
+8 WRITE ?40," Service Verified: "
SET Y=$PIECE(DGRP(.32),"^",2)
if Y]""
XECUTE ^DD("DD")
WRITE $SELECT(Y]"":Y,1:"NOT VERIFIED")
End DoDot:2
+9 ;from dgdem0
DO @("EN^"_DGROUT)
KILL Y
QUIT
End DoDot:1
+10 QUIT
+11 ;
+12 ; SDIEMM is used as a flag by AMBCARE Incomplete Encounter Management
+13 ; to bypass the embossing routines when calling load/edit from IEMM
+14 ;
+15 ; DG*5.3*1040 - If variable DGADDRE=-1, branch to RPOUT due to timeout; if DGRPOUT=1, branch to RPOUT as well
A1 Begin DoDot:1
+1 WRITE !,"Do you want to ",$SELECT(DGNEW:"enter",1:"edit")," Patient Data"
+2 SET %=1
DO YN^DICN
+3 IF +$GET(DGNEW)
QUIT
+4 ; DG*5.3*1040 - Store the return value in DGADDRE
SET DGADDRE=$$ADD^DGADDUTL($GET(DFN))
End DoDot:1
if $GET(DGADDRE)=-1
GOTO RPOUT
if '%
GOTO H
if %'=1
GOTO CK
SET DGRPV=0
DO EN1^DGRP
if +$GET(DGRPOUT)
GOTO RPOUT
DO MT(DFN)
DO CP
if $GET(DGPRFLG)=1
GOTO Q
if $GET(SDIEMM)
GOTO Q
if '$DATA(DA)
GOTO Q
GOTO EMBOS
+5 ;
H WRITE !?5,"Enter 'YES' to enter/edit registration data or 'NO' to continue without",!?5,"editing."
+1 GOTO A1
+2 ;
+3 ; DG*5.3*1040 - Only do if there wasn't a timeout so branch to RPOUT
CK SET DGEDCN=1
if +$GET(DGRPOUT)
GOTO RPOUT
DO ^DGRPC
DO MT(DFN)
DO CP
+1 if $GET(DGPRFLG)=1
GOTO Q
if $GET(SDIEMM)
GOTO Q
+2 IF $GET(DGER)[55
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Do you wish to return to Screen #9 to enter missing Income Data? "
DO ^DIR
KILL DIR
+3 ;G:Y ^DGRP9
+4 ;
EMBOS ;W ! D EMBOS^DGQEMA G A
+1 ;DG*5.3*921 Invoke eHMP demographic change checking
+2 DO T
+3 GOTO A
+4 ;
+5 ;
+6 ; DG*5.3*1040 - Clean variable DGTMOT
Q KILL X,Y,Z,DIC,DGELVER,DGNEW,DGRPV,DGTMOT,VET
QUIT
+1 ;
MT(DFN) ; Check if user requires a means test. Ask user if they want to proceedif
+1 ; one is required
+2 IF '$DATA(SDIEMM)
Begin DoDot:1
+3 NEW DGREQF,DIV
+4 DO EN^DGMTR
+5 IF DGREQF
if $PIECE($$MTS^DGMTU(DFN),U,2)="R"
DO EDT^DGMTU(DFN,DT)
+6 QUIT
End DoDot:1
+7 IF $DATA(SDIEMM)
Begin DoDot:1
+8 NEW DGMTI
+9 SET DGMTI=$$LST^DGMTU(DFN,SCINF("ENCOUNTER"),1)
+10 IF $PIECE(DGMTI,U,4)="R"
Begin DoDot:2
+11 SET DGMT0=$GET(^DGMT(408.31,+DGMTI,0))
SET DGMTDT=$PIECE(DGMT0,"^")
+12 IF '$$OKTOCONT(DGMTDT)
QUIT
+13 SET DGMTI=+DGMTI
SET DGMTYPT=1
SET DGMTACT="COM"
SET DGMTROU="COM^DGMTEO"
DO EN^DGMTSC
End DoDot:2
IF 1
+14 IF '$TEST
DO WARNING
+15 QUIT
End DoDot:1
+16 QUIT
+17 ;
WARNING ;
+1 ;prints a warning to the screen about means test
+2 ;
+3 WRITE !!,"A means test for this encounter date was not found and may be required!"
+4 WRITE !,"Further investigation will be needed."
+5 WRITE !
+6 DO PAUSE
+7 QUIT
+8 ;
PAUSE ;
+1 NEW DIR
+2 SET DIR(0)="FAO"
SET DIR("A")="Press ENTER to continue "
DO ^DIR
+3 QUIT
+4 ;
OKTOCONT(Y) ;
+1 ;
+2 NEW DIR
+3 WRITE !!,"Patient Requires a means Test"
+4 XECUTE ^DD("DD")
+5 WRITE !,"Primary Means Test Required from '",Y,"'",!
+6 ;
+7 IF $DATA(SDIEMM)
IF '$DATA(^XUSEC("SCENI MEANS TEST EDIT",DUZ))
Begin DoDot:1
+8 WRITE !,$CHAR(7),"You do not have the appropriate IEMM Security Key. Contact your supervisor.",!
+9 DO PAUSE
+10 SET Y=0
End DoDot:1
GOTO OKQ
+11 ;
+12 SET DIR("A")="Do you wish to proceed with the means test at this time"
+13 SET DIR("B")="YES"
+14 SET DIR(0)="Y"
+15 DO ^DIR
OKQ QUIT $SELECT(Y=1:1,1:0)
+1 ;
CP ;If not (autoexempt or MTested) & no CP test this year then
+1 ;prompt for add/edit cp test
+2 NEW DIV,DGIB,DGIBDT,DGX,X,DIRUT,DTOUT
+3 ;USE CP FLAG
if '$PIECE($GET(^DG(43,1,0)),U,41)
GOTO QTCP
+4 SET DGIBDT=$SELECT($DATA(DFN1):9999999-DFN1,1:DT)
+5 DO EN^DGMTCOR
+6 IF +$GET(DGNOCOPF)
SET DGMTCOR=0
+7 IF DGMTCOR
DO THRESH^DGMTCOU1(DGIBDT)
DO EDT^DGMTCOU(DFN,DT)
+8 KILL DGNOCOPF
QTCP QUIT
+1 ;
T ;
+1 ;DG*5.3*921- Check to ensure all demographic changes are passed to eHMP 10/2/15
+2 ;If we are editing demographics for an existing patient, get a snapshot after
+3 ;the changes and compare the before and after snapshots. If there are ANY changes
+4 ;invoke the unsolicited update protocol.
+5 IF DGNEW']""
Begin DoDot:1
+6 NEW DGFIELD,DGFILE,DGDA
+7 DO T59(DFN,"AFTER")
+8 IF $$T60("BEFORE","AFTER",.DGFIELD)
SET DGFILE=2
SET DGDA=DFN
if $LENGTH($TEXT(DG^HMPEVNT))
DO DG^HMPEVNT
End DoDot:1
+9 QUIT
+10 ;
T59(A,B) ;Get all the demographics that are supposed to trigger an unsolicited update
+1 ;DG*5.3*921
+2 ;A = DFN
+3 ;B = Return array
+4 NEW FLDS,INS
+5 SET FLDS=".01;.02;.03;.05;.08;.09;.351;.361;.364;.111;.1112;.112;.113;.114;.115;.131;.132;.134;"
+6 SET FLDS=FLDS_".211;.212;.213;.214;.216;.217;.218;.219;.301;.302;1901;.32102;.32103;.32201;.5295;"
+7 SET FLDS=FLDS_".133;.1211;.1212;.1213;.1214;.1215;.1216;.331;.332;.333;.334;.335;.336;.337;"
+8 SET FLDS=FLDS_".338;.339;.33011;.215;.21011;.3731;"
+9 DO GETS^DIQ(2,A_",",FLDS,,B)
+10 QUIT
+11 ;
T60(A,B,C) ;Compare the before and after arrays to see if any of the considerd demographics
+1 ;were changed
+2 ;DG*5.3*921
+3 ;A = "before" changes array
+4 ;B = "after" changes array
+5 ;Both A and B are of the form: A(2,DFN_",",Field#)=Field value. E.g. A(2,"3,",.114)="LOS ANGELES"
+6 ;C = the first field that was changed (e.g. .111 for street address line 1).
+7 ; This is an output parameter.
+8 ;Returns true (1) if any change is detected. Quits at the FIRST find.
+9 ; false (null) if there are no changes.
+10 NEW F,X,Y,Z
+11 SET (C,F,Z)=""
+12 FOR
SET Z=$ORDER(@A@(Z))
if $GET(F)!(Z'=+Z)
QUIT
Begin DoDot:1
+13 SET Y=""
+14 FOR
SET Y=$ORDER(@A@(Z,Y))
if $GET(F)!(Y']"")
QUIT
Begin DoDot:2
+15 SET X=""
+16 FOR
SET X=$ORDER(@A@(Z,Y,X))
if $GET(F)!(X'=+X)
QUIT
Begin DoDot:3
+17 IF @A@(Z,Y,X)'=$GET(@B@(Z,Y,X))
SET F=1
SET C=X
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT F
+19 ; DG*5.3*1040 - Entry point to quit and go to next select patient prompt
RPOUT ; Entry point if user timeout out
+1 SET DGRPOUT=""
+2 GOTO A
