DPTLK2 ;ALB/RMO,ERC - MAS Patient Look-up Add New Patient ;13 Feb 2020 3:00 PM
;;5.3;Registration;**32,197,214,244,532,578,615,620,647,680,702,653,915,1000**;Aug 13, 1993;Build 2
N DPTCT,DGVV,DPTLIDR,DGCOL S DGCOL=0
I $D(DDS) D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X DDXY
I '$D(DUZ(0)) W:DIC(0)["Q" !?3,*7,"Unable to Add Patient. Your Fileman Access Code is undefined." S DPTDFN=-1 G Q
I $S($D(DLAYGO):2\1-(DLAYGO\1),1:1),DUZ(0)'="@",$D(^DIC(2,0,"LAYGO")) F I=1:1 I DUZ(0)[$E(^("LAYGO"),I) Q:I'>$L(^("LAYGO")) S DPTDFN=-1 W:DIC(0)["Q" *7," ??" G Q
N DG20NAME S DG20NAME=$G(DPTX),DPTX=$$FORMAT^XLFNAME7(.DG20NAME,3,30,,1)
S DPTX=$S($E(DPTX)[""""&($E(DPTX,$L(DPTX))[""""):$P(DPTX,"""",2),$E(DPTX)["""":$P(DPTX,"""",2),$E(DPTX,$L(DPTX))["""":$P(DPTX,"""",1),1:DPTX)
I $L(DPTX)<3!($L(DPTX)>30)!(DPTX?1P.E)!(DPTX'[",")!(DPTX'?1U.ANP) W:DIC(0)["Q" *7," ??" S DPTDFN=-1 G Q
; DG*647
I $P($G(XQY0),U)="DG COLLATERAL PATIENT" S DGCOL=1,DGCOL("DR")=$P(DIC("DR"),";",5,8)
;**915 do enterprise search if register a patient option
I $P($G(XQY0),"^",2)="Register a Patient",$T(PATIENT^MPIFXMLP)'="" D G Q
. N DGSAVDFN
. I '$G(DGSEARCH) S DGSAVDFN=$$SEARCH^DPTLK7(DPTX,DPTXX)
. I $G(DGSAVDFN)>0 S DPTDFN=DGSAVDFN Q
. S DPTDFN=-1 S:DPTDFN<1&('$D(DTOUT)) DUOUT=1
K DPTLID I DIC(0)["E" D ASKADD D G Q:DPTDFN<0 I ('$D(DIC("DR")))!(DGCOL) D CHKID G Q:DPTDFN<0 D ^DPTLK3 G Q:DPTDFN<0 W !!?3,"...adding new patient"
.S:DPTDFN<1&('$D(DTOUT)) DUOUT=1
S X=DPTX,DPT("NO^")=$G(DIE("NO^")) K DD,DO,DPTX N DPTZNV
S:$D(DPT("DR")) DIC("DR")="S DIE(""NO^"")=""BACK"";"_DPT("DR")
I DGCOL S:$D(DPT("DR")) DIC("DR")=DPT("DR")_";"_DGCOL("DR")
D FILE^DICN K:$D(DPT("DR")) DIC("DR")
I +Y>0 W ?24,"...new patient added",!?3
S DPTDFN=Y S:$L(DPT("NO^")) DIE("NO^")=DPT("NO^")
;offer prompt of patient file components
K DA,DIE,DR
S DIE="^DPT(",DA=+Y,DR="S DIE(""NO^"")=""BACK"";.01///^S (X,DPTZNV)=$$NCEDIT^DPTNAME(DA,1,.DG20NAME)"
D ^DIE K DR
;look for other (local) identifiers
I '$D(DIC("DR")),DIC(0)["E",'DGCOL D
.F DPTID=0:0 S DPTID=$O(^DD(2,0,"ID",DPTID)) Q:'DPTID D
..I $F(DPTGID,U_DPTID_U) Q
..I '$D(^DD(2,DPTID,0)) Q
..S DPTLID=""
..S DPTLIDR=$S('$D(DPTLIDR):DPTID,1:DPTLIDR_";"_DPTID)
I $D(DPTLID) W !!?3,"Please enter the following additional information:",!?3 S DIE="^DPT(",DA=+DPTDFN,DIE("NO^")="BACK",DR=DPTLIDR D ^DIE K DIE,DA,DR
;
Q K DFN,DPT("DR"),DPTLID,DPTGID,DPTID,DPTID0,DPTIDS
Q
;
ASKADD I $D(DDS) I $Y>21 D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X DDXY
S Y=+$P(^DPT(0),U,4)+1 W !?3,*7,"ARE YOU ADDING ",$S(DPTX'?.N:"'"_DPTX_"' AS ",1:""),"A NEW PATIENT (THE ",Y,$S(Y#10=1&(Y#100-11):"ST",Y#10=2&(Y#100-12):"ND",Y#10=3&(Y#100-13):"RD",1:"TH"),")"
S %=2 D YN^DICN S DPTDFN=$S(%<0!(%=2):-1,%=1:1,1:0) I 'DPTDFN W !?6,"Enter 'YES' to add a new applicant, or 'NO' not to." G ASKADD
I %=1 S:$$CONF1^DPTNAME(DPTX)'=1 DPTDFN=-1
Q
;
CHKID K DFN S DPTDFN=1,DPTGID="^.02^.03^.09^391^1901^.301^994^" I DGCOL S DPTGID="^.03^.09^.02^.3601^"
F DPTCT=2:1 S DPTID=$P(DPTGID,U,DPTCT) Q:'DPTID!(DPTDFN<0) D CHKID1
Q
;
CHKID1 I $D(^DD(2,DPTID,0)) S DPT("DR")=$S('$D(DPT("DR")):DPTID,1:DPT("DR")_";"_DPTID),DPTID0=^DD(2,DPTID,0) D ASKID S:'$D(X) DPTDFN=-1
Q
;
ASKID N DGREC W !?3,"PATIENT ",$P(DPTID0,U),": " R X:DTIME D I $D(DTOUT)!$G(DUOUT)!($G(DGREC)=1) W !?6,*7,"<'",DPTX,"'> NOT ADDED" K X Q
.S:'$T DTOUT=U
.S:X="^" DUOUT=1
.Q:$D(DTOUT)!($G(DUOUT))!(X["^")
.I DPTID=.09 D
..;added with DG*5.3*653 - ERC
..I X="P"!(X="p") S DPTGID=$P(DPTGID,".09",1)_".09^.0906"_$P(DPTGID,".09",2)
..N DGNEWPT
..S DGNEWPT=1
..D REC^DGSEC
I X["^" W:$E(X)["^" !?6,*7,"Sorry, '^' not allowed!" W " ??" G ASKID
; field 994 is not a required field
I DPTID=994 I X["?" D HLPID G ASKID
I DPTID=994 I X="" G SKIP
I X["?"!(X="") W:X="" *7," ??" D HLPID G ASKID
I $P(DPTID0,U,2)["S" F I=1:1 S Y=$P($P(DPTID0,U,3),";",I) K:Y="" X Q:Y="" I $P(Y,":",1)=X!($E($P(Y,":",2),1,$L(X))=X) S X=$P(Y,":",1),DPTSET=$P(Y,":",2) Q
SKIP I $P(DPTID0,U,2)["P" D P1 G ASKID:Y'>0 Q:'$D(X) S DPTIDS(DPTID)=+Y,DPT("DR")=DPT("DR")_"////"_+Y K DPTSET Q ;**1000,Story 1171329 (mko): Return DPTIDS(DPTID)=pointer value and use 4-slash stuff for the field
I DPTID=.301,$D(X) D CHKIT Q:'$D(X) I $D(X) W:$D(DPTSET) " ",DPTSET S DPTIDS(DPTID)=X,DPT("DR")=DPT("DR")_"///"_X K DPTSET Q
I DPTID'=.301 X $P(DPTID0,U,5,99) I $D(X) W:$D(DPTSET) " ",DPTSET S DPTIDS(DPTID)=X,DPT("DR")=DPT("DR")_"///"_X K DPTSET Q
W:'$D(X)&($P(DPTID0,U,2)'["D") *7," ??" D HLPID G ASKID
;
HLPID W:$D(^DD(2,DPTID,.1)) !?5,^(.1) W:$D(^DD(2,DPTID,3)) !?5,^(3) I $D(X),X["?" F I=0:0 S I=$O(^DD(2,DPTID,21,I)) Q:'I!(I>3&(X?1"?")) I $D(^(I,0)) W !?5,^(0) I I>2,X?1"?" W !?5,"..."
X:$D(^DD(2,DPTID,4)) ^(4) I $P(DPTID0,U,2)["D" S X="?",%DT="E" D ^%DT
I $P(DPTID0,U,2)["S" W !?7,"CHOOSE FROM: " F I=1:1 S Y=$P($P(DPTID0,U,3),";",I) Q:Y="" W !?7,$P(Y,":",1),?15," ",$P(Y,":",2)
I $P(DPTID0,U,2)["P" D P1
Q
P1 I DPTID=".3601" S X=$$UCASE^DPTLK1(X) ;DG*5.3*680
S DPTDIC=$G(DIC),DPTDIC(0)=$G(DIC(0)) S:$D(DIC("S")) DPTDIC("S")=DIC("S") S:$D(DIC("W")) DPTDIC("W")=DIC("W") S DIC="^"_$P(DPTID0,"^",3),DIC(0)="QEMZ",D="B" D IX^DIC
S DIC=DPTDIC,DIC(0)=DPTDIC(0) S:$D(DPTDIC("S")) DIC("S")=DPTDIC("S") S:$D(DPTDIC("W")) DIC("W")=DPTDIC("W") K DPTDIC D DO^DIC1 S:X["^" DPTDFN=-1 I X'["^",X'["?",Y'>0 S X="?" G P1
; DG*5.3*680 S X=+Y stores the IEN of the sponsor picked to pass to FILE^DICN
I DPTID=".3601" S X=+Y I '$D(^DPT(+Y,"VET"))!($P($G(^DPT(+Y,"VET")),U)'="Y") D EN^DDIOL("Sponsor must be a veteran","","!?4") K X W !?6,*7,"<'",DPTX,"'> NOT ADDED"
Q
CHKIT ; do input transform for .301
I X'="Y" Q
S DGVV=DPTIDS(391)
;**1000,Story 1171329 (mko): SKIP was modified above to set DPTIDS(391) to the internal pointer value,
; so only try to convert to external form if it's not numeric.
I DGVV]"",DGVV'=+$P(DGVV,"E") S DGVV=$O(^DG(391,"B",DGVV,0))
S DGVV=$S($D(^DG(391,+DGVV,0)):$P(^(0),"^",2),1:"")
I DPTIDS(1901)'="Y",'DGVV D EN^DDIOL("Applicant is NOT a veteran!!","","!?4") K X W !?6,*7,"<'",DPTX,"'> NOT ADDED"
Q
DEL ;Delete logic
N I,J,A,G,Q,ERR S Q="""",ERR=0 F I=0:0 S I=$O(^DD(2,0,"PT",I)) Q:'I F J=0:0 S J=$O(^DD(2,0,"PT",I,J)) Q:'J D
.F K=0:0 S K=$O(^DD(I,+J,1,K)) Q:'K S A=$G(^(K,0)) I $L($P(A,U,2)),'$L($P(A,U,3)) D
..S G=$G(^DIC(+I,0,"GL")) Q:'$L(G) I $D(@(G_Q_$P(A,U,2)_Q_","_DA_")")) W !,"Entry in "_$P($G(^DIC(I,0)),U)_" ("_I_") refers to this patient" S ERR=1 Q
I ERR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDPTLK2 6446 printed Sep 23, 2025@20:36:48 Page 2
DPTLK2 ;ALB/RMO,ERC - MAS Patient Look-up Add New Patient ;13 Feb 2020 3:00 PM
+1 ;;5.3;Registration;**32,197,214,244,532,578,615,620,647,680,702,653,915,1000**;Aug 13, 1993;Build 2
+2 NEW DPTCT,DGVV,DPTLIDR,DGCOL
SET DGCOL=0
+3 IF $DATA(DDS)
DO CLRMSG^DDS
SET DX=0
SET DY=DDSHBX+1
XECUTE DDXY
+4 IF '$DATA(DUZ(0))
if DIC(0)["Q"
WRITE !?3,*7,"Unable to Add Patient. Your Fileman Access Code is undefined."
SET DPTDFN=-1
GOTO Q
+5 IF $SELECT($DATA(DLAYGO):2\1-(DLAYGO\1),1:1)
IF DUZ(0)'="@"
IF $DATA(^DIC(2,0,"LAYGO"))
FOR I=1:1
IF DUZ(0)[$EXTRACT(^("LAYGO"),I)
if I'>$LENGTH(^("LAYGO"))
QUIT
SET DPTDFN=-1
if DIC(0)["Q"
WRITE *7," ??"
GOTO Q
+6 NEW DG20NAME
SET DG20NAME=$GET(DPTX)
SET DPTX=$$FORMAT^XLFNAME7(.DG20NAME,3,30,,1)
+7 SET DPTX=$SELECT($EXTRACT(DPTX)[""""&($EXTRACT(DPTX,$LENGTH(DPTX))[""""):$PIECE(DPTX,"""",2),$EXTRACT(DPTX)["""":$PIECE(DPTX,"""",2),$EXTRACT(DPTX,$LENGTH(DPTX))["""":$PIECE(DPTX,"""",1),1:DPTX)
+8 IF $LENGTH(DPTX)<3!($LENGTH(DPTX)>30)!(DPTX?1P.E)!(DPTX'[",")!(DPTX'?1U.ANP)
if DIC(0)["Q"
WRITE *7," ??"
SET DPTDFN=-1
GOTO Q
+9 ; DG*647
+10 IF $PIECE($GET(XQY0),U)="DG COLLATERAL PATIENT"
SET DGCOL=1
SET DGCOL("DR")=$PIECE(DIC("DR"),";",5,8)
+11 ;**915 do enterprise search if register a patient option
+12 IF $PIECE($GET(XQY0),"^",2)="Register a Patient"
IF $TEXT(PATIENT^MPIFXMLP)'=""
Begin DoDot:1
+13 NEW DGSAVDFN
+14 IF '$GET(DGSEARCH)
SET DGSAVDFN=$$SEARCH^DPTLK7(DPTX,DPTXX)
+15 IF $GET(DGSAVDFN)>0
SET DPTDFN=DGSAVDFN
QUIT
+16 SET DPTDFN=-1
if DPTDFN<1&('$DATA(DTOUT))
SET DUOUT=1
End DoDot:1
GOTO Q
+17 KILL DPTLID
IF DIC(0)["E"
DO ASKADD
Begin DoDot:1
+18 if DPTDFN<1&('$DATA(DTOUT))
SET DUOUT=1
End DoDot:1
if DPTDFN<0
GOTO Q
IF ('$DATA(DIC("DR")))!(DGCOL)
DO CHKID
if DPTDFN<0
GOTO Q
DO ^DPTLK3
if DPTDFN<0
GOTO Q
WRITE !!?3,"...adding new patient"
+19 SET X=DPTX
SET DPT("NO^")=$GET(DIE("NO^"))
KILL DD,DO,DPTX
NEW DPTZNV
+20 if $DATA(DPT("DR"))
SET DIC("DR")="S DIE(""NO^"")=""BACK"";"_DPT("DR")
+21 IF DGCOL
if $DATA(DPT("DR"))
SET DIC("DR")=DPT("DR")_";"_DGCOL("DR")
+22 DO FILE^DICN
if $DATA(DPT("DR"))
KILL DIC("DR")
+23 IF +Y>0
WRITE ?24,"...new patient added",!?3
+24 SET DPTDFN=Y
if $LENGTH(DPT("NO^"))
SET DIE("NO^")=DPT("NO^")
+25 ;offer prompt of patient file components
+26 KILL DA,DIE,DR
+27 SET DIE="^DPT("
SET DA=+Y
SET DR="S DIE(""NO^"")=""BACK"";.01///^S (X,DPTZNV)=$$NCEDIT^DPTNAME(DA,1,.DG20NAME)"
+28 DO ^DIE
KILL DR
+29 ;look for other (local) identifiers
+30 IF '$DATA(DIC("DR"))
IF DIC(0)["E"
IF 'DGCOL
Begin DoDot:1
+31 FOR DPTID=0:0
SET DPTID=$ORDER(^DD(2,0,"ID",DPTID))
if 'DPTID
QUIT
Begin DoDot:2
+32 IF $FIND(DPTGID,U_DPTID_U)
QUIT
+33 IF '$DATA(^DD(2,DPTID,0))
QUIT
+34 SET DPTLID=""
+35 SET DPTLIDR=$SELECT('$DATA(DPTLIDR):DPTID,1:DPTLIDR_";"_DPTID)
End DoDot:2
End DoDot:1
+36 IF $DATA(DPTLID)
WRITE !!?3,"Please enter the following additional information:",!?3
SET DIE="^DPT("
SET DA=+DPTDFN
SET DIE("NO^")="BACK"
SET DR=DPTLIDR
DO ^DIE
KILL DIE,DA,DR
+37 ;
Q KILL DFN,DPT("DR"),DPTLID,DPTGID,DPTID,DPTID0,DPTIDS
+1 QUIT
+2 ;
ASKADD IF $DATA(DDS)
IF $Y>21
DO CLRMSG^DDS
SET DX=0
SET DY=DDSHBX+1
XECUTE DDXY
+1 SET Y=+$PIECE(^DPT(0),U,4)+1
WRITE !?3,*7,"ARE YOU ADDING ",$SELECT(DPTX'?.N:"'"_DPTX_"' AS ",1:""),"A NEW PATIENT (THE ",Y,$SELECT(Y#10=1&(Y#100-11):"ST",Y#10=2&(Y#100-12):"ND",Y#10=3&(Y#100-13):"RD",1:"TH"),")"
+2 SET %=2
DO YN^DICN
SET DPTDFN=$SELECT(%<0!(%=2):-1,%=1:1,1:0)
IF 'DPTDFN
WRITE !?6,"Enter 'YES' to add a new applicant, or 'NO' not to."
GOTO ASKADD
+3 IF %=1
if $$CONF1^DPTNAME(DPTX)'=1
SET DPTDFN=-1
+4 QUIT
+5 ;
CHKID KILL DFN
SET DPTDFN=1
SET DPTGID="^.02^.03^.09^391^1901^.301^994^"
IF DGCOL
SET DPTGID="^.03^.09^.02^.3601^"
+1 FOR DPTCT=2:1
SET DPTID=$PIECE(DPTGID,U,DPTCT)
if 'DPTID!(DPTDFN<0)
QUIT
DO CHKID1
+2 QUIT
+3 ;
CHKID1 IF $DATA(^DD(2,DPTID,0))
SET DPT("DR")=$SELECT('$DATA(DPT("DR")):DPTID,1:DPT("DR")_";"_DPTID)
SET DPTID0=^DD(2,DPTID,0)
DO ASKID
if '$DATA(X)
SET DPTDFN=-1
+1 QUIT
+2 ;
ASKID NEW DGREC
WRITE !?3,"PATIENT ",$PIECE(DPTID0,U),": "
READ X:DTIME
Begin DoDot:1
+1 if '$TEST
SET DTOUT=U
+2 if X="^"
SET DUOUT=1
+3 if $DATA(DTOUT)!($GET(DUOUT))!(X["^")
QUIT
+4 IF DPTID=.09
Begin DoDot:2
+5 ;added with DG*5.3*653 - ERC
+6 IF X="P"!(X="p")
SET DPTGID=$PIECE(DPTGID,".09",1)_".09^.0906"_$PIECE(DPTGID,".09",2)
+7 NEW DGNEWPT
+8 SET DGNEWPT=1
+9 DO REC^DGSEC
End DoDot:2
End DoDot:1
IF $DATA(DTOUT)!$GET(DUOUT)!($GET(DGREC)=1)
WRITE !?6,*7,"<'",DPTX,"'> NOT ADDED"
KILL X
QUIT
+10 IF X["^"
if $EXTRACT(X)["^"
WRITE !?6,*7,"Sorry, '^' not allowed!"
WRITE " ??"
GOTO ASKID
+11 ; field 994 is not a required field
+12 IF DPTID=994
IF X["?"
DO HLPID
GOTO ASKID
+13 IF DPTID=994
IF X=""
GOTO SKIP
+14 IF X["?"!(X="")
if X=""
WRITE *7," ??"
DO HLPID
GOTO ASKID
+15 IF $PIECE(DPTID0,U,2)["S"
FOR I=1:1
SET Y=$PIECE($PIECE(DPTID0,U,3),";",I)
if Y=""
KILL X
if Y=""
QUIT
IF $PIECE(Y,":",1)=X!($EXTRACT($PIECE(Y,":",2),1,$LENGTH(X))=X)
SET X=$PIECE(Y,":",1)
SET DPTSET=$PIECE(Y,":",2)
QUIT
SKIP ;**1000,Story 1171329 (mko): Return DPTIDS(DPTID)=pointer value and use 4-slash stuff for the field
IF $PIECE(DPTID0,U,2)["P"
DO P1
if Y'>0
GOTO ASKID
if '$DATA(X)
QUIT
SET DPTIDS(DPTID)=+Y
SET DPT("DR")=DPT("DR")_"////"_+Y
KILL DPTSET
QUIT
+1 IF DPTID=.301
IF $DATA(X)
DO CHKIT
if '$DATA(X)
QUIT
IF $DATA(X)
if $DATA(DPTSET)
WRITE " ",DPTSET
SET DPTIDS(DPTID)=X
SET DPT("DR")=DPT("DR")_"///"_X
KILL DPTSET
QUIT
+2 IF DPTID'=.301
XECUTE $PIECE(DPTID0,U,5,99)
IF $DATA(X)
if $DATA(DPTSET)
WRITE " ",DPTSET
SET DPTIDS(DPTID)=X
SET DPT("DR")=DPT("DR")_"///"_X
KILL DPTSET
QUIT
+3 if '$DATA(X)&($PIECE(DPTID0,U,2)'["D")
WRITE *7," ??"
DO HLPID
GOTO ASKID
+4 ;
HLPID if $DATA(^DD(2,DPTID,.1))
WRITE !?5,^(.1)
if $DATA(^DD(2,DPTID,3))
WRITE !?5,^(3)
IF $DATA(X)
IF X["?"
FOR I=0:0
SET I=$ORDER(^DD(2,DPTID,21,I))
if 'I!(I>3&(X?1"?"))
QUIT
IF $DATA(^(I,0))
WRITE !?5,^(0)
IF I>2
IF X?1"?"
WRITE !?5,"..."
+1 if $DATA(^DD(2,DPTID,4))
XECUTE ^(4)
IF $PIECE(DPTID0,U,2)["D"
SET X="?"
SET %DT="E"
DO ^%DT
+2 IF $PIECE(DPTID0,U,2)["S"
WRITE !?7,"CHOOSE FROM: "
FOR I=1:1
SET Y=$PIECE($PIECE(DPTID0,U,3),";",I)
if Y=""
QUIT
WRITE !?7,$PIECE(Y,":",1),?15," ",$PIECE(Y,":",2)
+3 IF $PIECE(DPTID0,U,2)["P"
DO P1
+4 QUIT
P1 ;DG*5.3*680
IF DPTID=".3601"
SET X=$$UCASE^DPTLK1(X)
+1 SET DPTDIC=$GET(DIC)
SET DPTDIC(0)=$GET(DIC(0))
if $DATA(DIC("S"))
SET DPTDIC("S")=DIC("S")
if $DATA(DIC("W"))
SET DPTDIC("W")=DIC("W")
SET DIC="^"_$PIECE(DPTID0,"^",3)
SET DIC(0)="QEMZ"
SET D="B"
DO IX^DIC
+2 SET DIC=DPTDIC
SET DIC(0)=DPTDIC(0)
if $DATA(DPTDIC("S"))
SET DIC("S")=DPTDIC("S")
if $DATA(DPTDIC("W"))
SET DIC("W")=DPTDIC("W")
KILL DPTDIC
DO DO^DIC1
if X["^"
SET DPTDFN=-1
IF X'["^"
IF X'["?"
IF Y'>0
SET X="?"
GOTO P1
+3 ; DG*5.3*680 S X=+Y stores the IEN of the sponsor picked to pass to FILE^DICN
+4 IF DPTID=".3601"
SET X=+Y
IF '$DATA(^DPT(+Y,"VET"))!($PIECE($GET(^DPT(+Y,"VET")),U)'="Y")
DO EN^DDIOL("Sponsor must be a veteran","","!?4")
KILL X
WRITE !?6,*7,"<'",DPTX,"'> NOT ADDED"
+5 QUIT
CHKIT ; do input transform for .301
+1 IF X'="Y"
QUIT
+2 SET DGVV=DPTIDS(391)
+3 ;**1000,Story 1171329 (mko): SKIP was modified above to set DPTIDS(391) to the internal pointer value,
+4 ; so only try to convert to external form if it's not numeric.
+5 IF DGVV]""
IF DGVV'=+$PIECE(DGVV,"E")
SET DGVV=$ORDER(^DG(391,"B",DGVV,0))
+6 SET DGVV=$SELECT($DATA(^DG(391,+DGVV,0)):$PIECE(^(0),"^",2),1:"")
+7 IF DPTIDS(1901)'="Y"
IF 'DGVV
DO EN^DDIOL("Applicant is NOT a veteran!!","","!?4")
KILL X
WRITE !?6,*7,"<'",DPTX,"'> NOT ADDED"
+8 QUIT
DEL ;Delete logic
+1 NEW I,J,A,G,Q,ERR
SET Q=""""
SET ERR=0
FOR I=0:0
SET I=$ORDER(^DD(2,0,"PT",I))
if 'I
QUIT
FOR J=0:0
SET J=$ORDER(^DD(2,0,"PT",I,J))
if 'J
QUIT
Begin DoDot:1
+2 FOR K=0:0
SET K=$ORDER(^DD(I,+J,1,K))
if 'K
QUIT
SET A=$GET(^(K,0))
IF $LENGTH($PIECE(A,U,2))
IF '$LENGTH($PIECE(A,U,3))
Begin DoDot:2
+3 SET G=$GET(^DIC(+I,0,"GL"))
if '$LENGTH(G)
QUIT
IF $DATA(@(G_Q_$PIECE(A,U,2)_Q_","_DA_")"))
WRITE !,"Entry in "_$PIECE($GET(^DIC(I,0)),U)_" ("_I_") refers to this patient"
SET ERR=1
QUIT
End DoDot:2
End DoDot:1
+4 IF ERR
