source: WorldVistAEHR/trunk/r/IHS_ROUTINES-AUP/AUPNLK.m@ 1710

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

initial load of WorldVistAEHR

File size: 5.2 KB
Line 
1AUPNLK ; IHS/CMI/LAB - IHS PATIENT LOOKUP MAIN ROUTINE 24-MAY-1993 ;8DEC2006
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**167**;Aug 12, 1996;Build 22
3 ;patch 5 - fm v22
4 ;'Modified' MAS Patient Look-up Routine for ADT Version 3.6, June 1987
5 ; This routine will not be executed if DIC(0)["I" or caller
6 ; used IX^DIC.
7 ;
8 ; AUPQF values have the following meaning:
9 ; 0 = Initial state
10 ; 1 = Primary error
11 ; 2 = Operator/time out
12 ; 3 = Retry
13 ; 4 = Hit
14 ; 5 = Added patient
15 ;;EP;ENTERNAL ENTRY POINT
16 ;
17START ;
18 ;Next line makes all patients accessable in a look up.
19 N AUPNLK I $G(DUZ("AG"))="E" S AUPNLK("ALL")=1 ;New code DAOU/JLG 1/26/05
20 D ^AUPNLKI ; Initialization
21 I AUPQF D EOJ Q
22 D FINDPAT ; Find patient
23 D EOJ ; Cleanup
24 S:'$D(X) X=""
25 Q
26 ;
27FINDPAT ; FIND PATIENT
28 I DIC(0)'["A" S AUPX=X D CHKPAT D:AUPQF=4 HIT Q
29 F AUPL=0:0 S AUPQF=0 D ASKPAT D CHKPAT D:AUPQF=4 HIT Q:AUPQF'=3
30 Q
31 ;
32ASKPAT ;
33 K AUPCNT,AUPD,AUPIDS,AUPIFN,AUPIFNS,AUPNDAYS,AUPNDOB,AUPNDOD,AUPNICK,AUPNPAT,AUPNSEX,AUPNUM,AUPS,AUPSEL,DTOUT,DUOUT ; IHS/SD/EFG AUPN*99.1*13 3/16/2004
34 ;N AUP,AUPBEG,AUPCNT,AUPDFN,AUPDIC,AUPDICS,AUPDICW,AUPI,AUPIFN,AUPIFNS,AUPIX,AUPL,AUPNICK,AUPNUM,AUPQF,AUPS,AUPSEL,AUPLP1,AUPMAPY ; IHS/SD/EFG AUPN*99.1*13 3/16/2004
35 S AUPX=""
36 ;W !!,$S($D(DIC("A")):DIC("A"),1:"Select PATIENT NAME: ") I $D(DIC("B")),DIC("B")]"" W DIC("B"),"// " S AUPX=DIC("B")
37 ;D EN^DDIOL($S($D(DIC("A")):DIC("A"),1:"Select PATIENT NAME: "),"","!!") I $D(DIC("B")),DIC("B")]"" D EN^DDIOL(DIC("B")_"// ") S AUPX=DIC("B")
38 NEW DSPVAL S DSPVAL=$S($D(DIC("A")):DIC("A"),1:"Select PATIENT NAME: ")
39 I $D(DIC("B")),DIC("B")]"" S AUPX=DIC("B"),DSPVAL=DSPVAL_DIC("B")_"//"
40 D EN^DDIOL(DSPVAL)
41 R X:DTIME S:X["^" DUOUT=1 S:'$T DTOUT=1,X="^"
42 S:X]"" AUPX=X
43 Q
44 ;
45CHKPAT ;
46 K AUPIFNS,AUPS,AUPSEL
47 S AUPCNT=0
48 I AUPX=""!(AUPX["^") S AUPQF=2 Q
49 I AUPX["?" D ^AUPNLKH S AUPQF=3 Q
50 ;I AUPX?1A!(AUPX'?.ANP)!($L(AUPX)>30)!($E(AUPX)=",") W:DIC(0)["Q" *7," ??" S AUPQF=3 Q
51 I AUPX?1A!(AUPX'?.ANP)!($L(AUPX)>30)!($E(AUPX)=",") D:DIC(0)["Q" S AUPQF=3 Q
52 .NEW % S %=$C(7)_" ??" D EN^DDIOL(%)
53 I '$D(DIADD),AUPX'?1"""".E1"""" D LOOKUPS^AUPNLKB ; Find patient
54 Q:AUPQF ; Quit if patient found
55 I DIC(0)["L" D ADDPAT^AUPNLKB ; Try adding the patient
56 Q:AUPQF ; Quit if add successful
57 ;W:DIC(0)["Q" *7," ??"
58 I DIC(0)["Q" D EN^DDIOL($C(7)_" ??")
59 S AUPQF=3
60 Q
61 ;
62HIT ;
63 I DIC(0)["E" D WRT
64 Q:AUPQF'=4
65 I '$D(DICR),$T(SENS^DGSEC4)]"" S Y=+AUPDFN D ^DGSEC S AUPDFN=Y I Y<0 S AUPQF=3 Q ;IHS/ANMC/LJF 9/1/2000
66 S AUPX=$P(AUPS(AUPDFN),U,2),AUPDFN=AUPDFN_U_$P(AUPS(AUPDFN),U)
67 N DA,X S DA=+AUPDFN X $P(^DD(2,.081,0),U,5,99) I $G(X),DIC(0)["E" D DUPECHK
68 Q
69 ;
70WRT ;
71 I $P(@(AUPDIC_"0)"),U,2)["O"!('$D(AUPSEL)&($D(AUPNICK(AUPDFN)))) D WRT2
72 Q:AUPQF'=4
73 I '$D(AUPSEL),'$D(AUPNICK(AUPDFN)),$P($P(AUPS(AUPDFN),U,2),AUPX)="" D
74 .N % S %=$P(AUPS(AUPDFN),U,2) S:$P(AUPS(AUPDFN),U)'=% %=$E($P(AUPS(AUPDFN),U,2),$L(AUPX)+1,$L($P(AUPS(AUPDFN),U,2))) D EN^DDIOL(%)
75 D EN^DDIOL($S($D(AUPSEL)!($P(AUPS(AUPDFN),U)'=$P(AUPS(AUPDFN),U,2)):" "_$P(AUPS(AUPDFN),U)_" ",1:" "))
76 S Y=+AUPDFN X:$D(^DPT(AUPDFN,0)) DIC("W")
77 Q
78 ;
79WRT2 ;
80 D EN^DDIOL(" "_$P(^DPT(AUPDFN,0),U)),EN^DDIOL("OK","","!?8")
81 S %=1 D YN^DICN
82 S:%'=1 AUPQF=3,AUPDFN=-1
83 K %,%Y
84 Q
85 ;
86DUPECHK ; SELECTED PATIENT HAS UNRESOLVED DUPES
87 I $D(^VA(15,"ALK","DPT(",+Y,2)) S AUPMT=$O(^(2,0)) D DUPECHK2 Q
88 ; Code to inform user of potential duplicates would go here.
89 Q
90 ;
91DUPECHK2 ; VERIFIED DUPE
92 D EN^DDIOL("The patient you have selected is a 'verified duplicate' of","","!?6")
93 D EN^DDIOL($P(^DPT(AUPMT,0),U),"","!?12") D ;S AUPSY=Y,Y=AUPMT D SET^AUPNLKZ X DIC("W") S Y=AUPSY ;D RESET^AUPNLKZ
94 .N Y S Y=AUPMT X DIC("W")
95 D EN^DDIOL("If you are adding data for this patient please reselect!","","!?6")
96 K AUPMT,AUPSY
97 Q
98 ;
99EOJ ;
100 K AUPNLK("ICN")
101 I AUPQF=1 S Y=-1 K AUPQF,AUPDIC,DIC("W") Q
102 I AUPQF=2!(AUPQF=3) S Y=-1,X=AUPX D KILL Q
103 S Y=AUPDFN,X=AUPX
104 D EOJ2
105 D KILL
106 Q
107 ;
108EOJ2 ;
109 ; - FOLLOW MERGE CHAIN -
110 S AUPSY=Y
111 F AUPL=0:0 Q:'$P(^DPT(+Y,0),U,19) S Y=$P(^(0),U,19),Y=Y_U_$P(^DPT(Y,0),U,1) ; Will abort if no ^DPT entry for Y
112 I DIC(0)["E",Y'=AUPSY D EN^DDIOL("You now have patient "_$P(^DPT(+Y,0),U),"","!?6")
113 K AUPSY
114 ; -- SPACE BAR AND Y(0) --
115 S:DIC(0)'["F" ^DISV($S($D(DUZ)#2:DUZ,1:0),"^DPT(")=+Y,^DISV($S($D(DUZ)#2:DUZ,1:0),"^AUPNPAT(")=+Y S:DIC(0)["Z" Y(0)=^DPT(+Y,0),Y(0,0)=$P(^(0),U,1)
116 ; -- RESET Y AND Y(0) FOR 9000001 LOOKUP --
117 I AUPDIC="^AUPNPAT(" S $P(Y,U,2)=+Y I DIC(0)["Z" S Y(0)=^AUPNPAT(+Y,0)
118 ; -- POST SELECTION --
119 X:$D(^DD(2,0,"ACT")) ^("ACT") X:$D(^DD(9000001,0,"ACT")) ^("ACT")
120 ; -- SET NAKED --
121 S:$D(AUPDIC) DIC=AUPDIC I $D(@(DIC_"+Y,0)"))
122 ; ----- -
123 Q
124 ;
125KILL ;
126 ; - RESTORE DIC AND DIC("S") -
127 S:$D(AUPDIC) DIC=AUPDIC
128 ;K DIC("S","IHSORIG"),DIC("S","IHSLOOK") K:$D(DIC("S"))<10 DIC("S") S:$D(AUPDICS) DIC("S")=AUPDICS
129 K AUPNORIG,AUPNLOOK K:$D(DIC("S"))<10 DIC("S") S:$D(AUPDICS) DIC("S")=AUPDICS ;IHS/ANMC/CLS 09/13/2000 fm v22
130 ; - - -
131 K D,DIC("W"),DO
132 ;D:$D(AUPNLK("ALL")) RESET^AUPNLKZ ; Undocumented feature
133 S AUPX=$S($D(AUPNLK("ALL")):1,1:0) K AUPNLK S:AUPX AUPNLK("ALL")=1
134 K AUP,AUPBEG,AUPCNT,AUPDFN,AUPDIC,AUPDICS,AUPDICW,AUPI,AUPIFN,AUPIFNS,AUPIX,AUPL,AUPNICK,AUPNUM,AUPQF,AUPS,AUPSEL,AUPX,AUPLP1,AUPMAPY ; IHS/SD/EFG AUPN*99.1*13 3/16/2004
135 Q
Note: See TracBrowser for help on using the repository browser.