source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DPTLK2.m@ 1104

DPTLK2 ;ALB/RMO,ERC - MAS Patient Look-up Add New Patient ; 07/07/06
 ;;5.3;Registration;**32,197,214,244,532,578,615,620,647,680,702,653**;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=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)
 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)=X,DPT("DR")=DPT("DR")_"///"_X K DPTSET Q
 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),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