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

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 5.6 KB
Line 
1DPTLK2 ;ALB/RMO,ERC - MAS Patient Look-up Add New Patient ; 07/07/06
2 ;;5.3;Registration;**32,197,214,244,532,578,615,620,647,680,702,653**;Aug 13, 1993;Build 2
3 N DPTCT,DGVV,DPTLIDR,DGCOL S DGCOL=0
4 I $D(DDS) D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X DDXY
5 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
6 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
7 N DG20NAME S DG20NAME=DPTX,DPTX=$$FORMAT^XLFNAME7(.DG20NAME,3,30,,1)
8 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)
9 I $L(DPTX)<3!($L(DPTX)>30)!(DPTX?1P.E)!(DPTX'[",")!(DPTX'?1U.ANP) W:DIC(0)["Q" *7," ??" S DPTDFN=-1 G Q
10 ; DG*647
11 I $P($G(XQY0),U)="DG COLLATERAL PATIENT" S DGCOL=1,DGCOL("DR")=$P(DIC("DR"),";",5,8)
12 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"
13 .S:DPTDFN<1&('$D(DTOUT)) DUOUT=1
14 S X=DPTX,DPT("NO^")=$G(DIE("NO^")) K DD,DO,DPTX N DPTZNV
15 S:$D(DPT("DR")) DIC("DR")="S DIE(""NO^"")=""BACK"";"_DPT("DR")
16 I DGCOL S:$D(DPT("DR")) DIC("DR")=DPT("DR")_";"_DGCOL("DR")
17 D FILE^DICN K:$D(DPT("DR")) DIC("DR")
18 I +Y>0 W ?24,"...new patient added",!?3
19 S DPTDFN=Y S:$L(DPT("NO^")) DIE("NO^")=DPT("NO^")
20 ;offer prompt of patient file components
21 K DA,DIE,DR
22 S DIE="^DPT(",DA=+Y,DR="S DIE(""NO^"")=""BACK"";.01///^S (X,DPTZNV)=$$NCEDIT^DPTNAME(DA,1,.DG20NAME)"
23 D ^DIE K DR
24 ;look for other (local) identifiers
25 I '$D(DIC("DR")),DIC(0)["E",'DGCOL D
26 .F DPTID=0:0 S DPTID=$O(^DD(2,0,"ID",DPTID)) Q:'DPTID D
27 ..I $F(DPTGID,U_DPTID_U) Q
28 ..I '$D(^DD(2,DPTID,0)) Q
29 ..S DPTLID=""
30 ..S DPTLIDR=$S('$D(DPTLIDR):DPTID,1:DPTLIDR_";"_DPTID)
31 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
32 ;
33Q K DFN,DPT("DR"),DPTLID,DPTGID,DPTID,DPTID0,DPTIDS
34 Q
35 ;
36ASKADD I $D(DDS) I $Y>21 D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X DDXY
37 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"),")"
38 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
39 I %=1 S:$$CONF1^DPTNAME(DPTX)'=1 DPTDFN=-1
40 Q
41 ;
42CHKID K DFN S DPTDFN=1,DPTGID="^.02^.03^.09^391^1901^.301^994^" I DGCOL S DPTGID="^.03^.09^.02^.3601^"
43 F DPTCT=2:1 S DPTID=$P(DPTGID,U,DPTCT) Q:'DPTID!(DPTDFN<0) D CHKID1
44 Q
45 ;
46CHKID1 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
47 Q
48 ;
49ASKID 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
50 .S:'$T DTOUT=U
51 .S:X="^" DUOUT=1
52 .Q:$D(DTOUT)!($G(DUOUT))!(X["^")
53 .I DPTID=.09 D
54 ..;added with DG*5.3*653 - ERC
55 ..I X="P"!(X="p") S DPTGID=$P(DPTGID,".09",1)_".09^.0906"_$P(DPTGID,".09",2)
56 ..N DGNEWPT
57 ..S DGNEWPT=1
58 ..D REC^DGSEC
59 I X["^" W:$E(X)["^" !?6,*7,"Sorry, '^' not allowed!" W " ??" G ASKID
60 ; field 994 is not a required field
61 I DPTID=994 I X["?" D HLPID G ASKID
62 I DPTID=994 I X="" G SKIP
63 I X["?"!(X="") W:X="" *7," ??" D HLPID G ASKID
64 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
65SKIP 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
66 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
67 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
68 W:'$D(X)&($P(DPTID0,U,2)'["D") *7," ??" D HLPID G ASKID
69 ;
70HLPID 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,"..."
71 X:$D(^DD(2,DPTID,4)) ^(4) I $P(DPTID0,U,2)["D" S X="?",%DT="E" D ^%DT
72 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)
73 I $P(DPTID0,U,2)["P" D P1
74 Q
75P1 I DPTID=".3601" S X=$$UCASE^DPTLK1(X) ;DG*5.3*680
76 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
77 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
78 ; DG*5.3*680 S X=+Y stores the IEN of the sponsor picked to pass to FILE^DICN
79 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"
80 Q
81CHKIT ; do input transform for .301
82 I X'="Y" Q
83 S DGVV=DPTIDS(391),DGVV=$O(^DG(391,"B",DGVV,0))
84 S DGVV=$S($D(^DG(391,+DGVV,0)):$P(^(0),"^",2),1:"")
85 I DPTIDS(1901)'="Y",'DGVV D EN^DDIOL("Applicant is NOT a veteran!!","","!?4") K X W !?6,*7,"<'",DPTX,"'> NOT ADDED"
86 Q
87DEL ;Delete logic
88 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
89 .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
90 ..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
91 I ERR
Note: See TracBrowser for help on using the repository browser.