AUPNLKB ; IHS/CMI/LAB - Broke up AUPNLK because of size ;
;;99.1;IHS DICTIONARIES (PATIENT);;MAR 09, 1999
;
LOOKUPS ; EXTERNAL ENTRY POINT
S AUPBEG=1,(AUPDFN,AUPNUM)=0
D QUICK ; Try quick lookups first
Q:AUPQF
D XREFS ; Try lookup on xrefs
Q:AUPQF
I DIC(0)["N" D DFN ; Try by DFN
Q:AUPQF
Q
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
QUICK ; QUICK LOOKUPS
I $D(AUPNLK("ICN")) D ICN Q
I AUPX=+AUPX,$L(AUPX)<7 D IHSCHRT I AUPDFN>0 S AUPQF=4 Q
I AUPX["^" S AUPQF=3 Q
S AUPDFN=0
I AUPX=" " S Y=$S('($D(DUZ)#2):-1,$D(^DISV(DUZ,"^DPT(")):^("^DPT("),1:-1) D SETAUP^AUPNLKUT:Y>0 S AUPDFN=$S($D(AUPS(Y)):Y,1:-1) D CHKDFN K AUPSP Q
I $E(AUPX)="`" S Y=$S($D(^DPT(+$P(AUPX,"`",2),0)):+$P(AUPX,"`",2),1:-1) D SETAUP^AUPNLKUT:Y>0 S AUPDFN=$S($D(AUPS(Y)):Y,1:-1) D CHKDFN Q
Q
;
ICN ; LOOKUP BY ICN (for MFI)
S AUPDFN=-1
S X=$P(AUPNLK("ICN"),":",2),AUPNLK("ICN")=$P(AUPNLK("ICN"),":",1)
Q:X'?1N.N
Q:AUPNLK("ICN")'?1N.N
Q:'$D(^AUTTLOC(AUPNLK("ICN"),0))
Q:'$D(^AUPNPAT("AICN",AUPNLK("ICN"),X))
S (AUPDFN,Y)=$O(^(X,0))
S:$D(DIC("S")) AUPNLK("DICS")=DIC("S") K DIC("S") D SETAUP^AUPNLKUT S:$D(AUPNLK("DICS")) DIC("S")=AUPNLK("DICS") K AUPNLK("DICS")
S AUPQF=4
Q
;
IHSCHRT ; LOOKUP CHART #
Q:'$D(^AUPNPAT("D",AUPX))
D IHSCHRT1:DUZ(2),IHSCHRT2:'DUZ(2)
Q
;
IHSCHRT1 ; LOOKUP CHART # WHEN DUZ(2)'=0
F Y=0:0 S Y=$O(^AUPNPAT("D",AUPX,Y)) Q:Y="" Q:$D(^(Y,DUZ(2)))
Q:Y=""
D SETAUP^AUPNLKUT
S AUPDFN=$S($D(AUPS(Y)):Y,1:-1)
Q
;
IHSCHRT2 ; LOOKUP CHART # WHEN DUZ(2)=0
F AUPIFN=0:0 S AUPIFN=$O(^AUPNPAT("D",AUPX,AUPIFN)) Q:AUPIFN="" S Y=AUPIFN D SETAUP^AUPNLKUT
S:AUPCNT=1&($D(AUPIFNS(AUPCNT))) AUPDFN=+AUPIFNS(AUPCNT) D PRTAUP^AUPNLKUT:'AUPDFN&(AUPCNT>AUPNUM)&(DIC(0)["E") I 'AUPDFN,$D(AUPSEL),AUPSEL="" S AUPDFN=-1
Q
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
XREFS ; LOOKUP BY XREFS
; Upon returning from ^AUPNLK1 AUPDFN values/meanings are:
; 0 = No hits
; <0 = Hits but no selection
; >0 = Selection made
D ^AUPNLK1
I $D(DTOUT) S AUPQF=2 Q
I AUPDFN>0 S AUPQF=4 Q
I AUPDFN<0 S AUPQF=3 Q
Q
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
DFN ; LOOKUP BY DFN
Q:AUPX'?1N.N
S AUPDFN=-1,AUPBEG=1,AUPNUM=0
I $D(^DPT(AUPX,0)) S Y=X D SETAUP^AUPNLKUT S AUPDFN=$S($D(AUPS(Y)):Y,1:-1) D CHKDFN Q
Q
;
CHKDFN ;
S:'$D(AUPDFN) AUPDFN=-1
I +AUPDFN'>0!('$D(AUPS(+AUPDFN))) D:DIC(0)["Q" EN^DDIOL($C(7)_" ??") S AUPQF=3 Q
S AUPQF=4
Q
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
ADDPAT ; EXTERNAL ENTRY POINT - ADD PATIENT
I AUPX?1"""".E1"""" S AUPX=$E(AUPX,2,$L(AUPX)-1)
D ^AUPNLK2
S Y=AUPDFN
I Y<0 S AUPQF=3 Q
S AUPQF=5
Q
AUPNLKB ; IHS/CMI/LAB - Broke up AUPNLK because of size ;
+1 ;;99.1;IHS DICTIONARIES (PATIENT);;MAR 09, 1999
+2 ;
LOOKUPS ; EXTERNAL ENTRY POINT
+1 SET AUPBEG=1
SET (AUPDFN,AUPNUM)=0
+2 ; Try quick lookups first
DO QUICK
+3 IF AUPQF
QUIT
+4 ; Try lookup on xrefs
DO XREFS
+5 IF AUPQF
QUIT
+6 ; Try by DFN
IF DIC(0)["N"
DO DFN
+7 IF AUPQF
QUIT
+8 QUIT
+9 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+10 ;
QUICK ; QUICK LOOKUPS
+1 IF $DATA(AUPNLK("ICN"))
DO ICN
QUIT
+2 IF AUPX=+AUPX
IF $LENGTH(AUPX)<7
DO IHSCHRT
IF AUPDFN>0
SET AUPQF=4
QUIT
+3 IF AUPX["^"
SET AUPQF=3
QUIT
+4 SET AUPDFN=0
+5 IF AUPX=" "
SET Y=$SELECT('($DATA(DUZ)#2):-1,$DATA(^DISV(DUZ,"^DPT(")):^("^DPT("),1:-1)
IF Y>0
DO SETAUP^AUPNLKUT
SET AUPDFN=$SELECT($DATA(AUPS(Y)):Y,1:-1)
DO CHKDFN
KILL AUPSP
QUIT
+6 IF $EXTRACT(AUPX)="`"
SET Y=$SELECT($DATA(^DPT(+$PIECE(AUPX,"`",2),0)):+$PIECE(AUPX,"`",2),1:-1)
IF Y>0
DO SETAUP^AUPNLKUT
SET AUPDFN=$SELECT($DATA(AUPS(Y)):Y,1:-1)
DO CHKDFN
QUIT
+7 QUIT
+8 ;
ICN ; LOOKUP BY ICN (for MFI)
+1 SET AUPDFN=-1
+2 SET X=$PIECE(AUPNLK("ICN"),":",2)
SET AUPNLK("ICN")=$PIECE(AUPNLK("ICN"),":",1)
+3 IF X'?1N.N
QUIT
+4 IF AUPNLK("ICN")'?1N.N
QUIT
+5 IF '$DATA(^AUTTLOC(AUPNLK("ICN"),0))
QUIT
+6 IF '$DATA(^AUPNPAT("AICN",AUPNLK("ICN"),X))
QUIT
+7 SET (AUPDFN,Y)=$ORDER(^(X,0))
+8 IF $DATA(DIC("S"))
SET AUPNLK("DICS")=DIC("S")
KILL DIC("S")
DO SETAUP^AUPNLKUT
IF $DATA(AUPNLK("DICS"))
SET DIC("S")=AUPNLK("DICS")
KILL AUPNLK("DICS")
+9 SET AUPQF=4
+10 QUIT
+11 ;
IHSCHRT ; LOOKUP CHART #
+1 IF '$DATA(^AUPNPAT("D",AUPX))
QUIT
+2 IF DUZ(2)
DO IHSCHRT1
IF 'DUZ(2)
DO IHSCHRT2
+3 QUIT
+4 ;
IHSCHRT1 ; LOOKUP CHART # WHEN DUZ(2)'=0
+1 FOR Y=0:0
SET Y=$ORDER(^AUPNPAT("D",AUPX,Y))
IF Y=""
QUIT
IF $DATA(^(Y,DUZ(2)))
QUIT
+2 IF Y=""
QUIT
+3 DO SETAUP^AUPNLKUT
+4 SET AUPDFN=$SELECT($DATA(AUPS(Y)):Y,1:-1)
+5 QUIT
+6 ;
IHSCHRT2 ; LOOKUP CHART # WHEN DUZ(2)=0
+1 FOR AUPIFN=0:0
SET AUPIFN=$ORDER(^AUPNPAT("D",AUPX,AUPIFN))
IF AUPIFN=""
QUIT
SET Y=AUPIFN
DO SETAUP^AUPNLKUT
+2 IF AUPCNT=1&($DATA(AUPIFNS(AUPCNT)))
SET AUPDFN=+AUPIFNS(AUPCNT)
IF 'AUPDFN&(AUPCNT>AUPNUM)&(DIC(0)["E")
DO PRTAUP^AUPNLKUT
IF 'AUPDFN
IF $DATA(AUPSEL)
IF AUPSEL=""
SET AUPDFN=-1
+3 QUIT
+4 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+5 ;
XREFS ; LOOKUP BY XREFS
+1 ; Upon returning from ^AUPNLK1 AUPDFN values/meanings are:
+2 ; 0 = No hits
+3 ; <0 = Hits but no selection
+4 ; >0 = Selection made
+5 DO ^AUPNLK1
+6 IF $DATA(DTOUT)
SET AUPQF=2
QUIT
+7 IF AUPDFN>0
SET AUPQF=4
QUIT
+8 IF AUPDFN<0
SET AUPQF=3
QUIT
+9 QUIT
+10 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+11 ;
DFN ; LOOKUP BY DFN
+1 IF AUPX'?1N.N
QUIT
+2 SET AUPDFN=-1
SET AUPBEG=1
SET AUPNUM=0
+3 IF $DATA(^DPT(AUPX,0))
SET Y=X
DO SETAUP^AUPNLKUT
SET AUPDFN=$SELECT($DATA(AUPS(Y)):Y,1:-1)
DO CHKDFN
QUIT
+4 QUIT
+5 ;
CHKDFN ;
+1 IF '$DATA(AUPDFN)
SET AUPDFN=-1
+2 IF +AUPDFN'>0!('$DATA(AUPS(+AUPDFN)))
IF DIC(0)["Q"
DO EN^DDIOL($CHAR(7)_" ??")
SET AUPQF=3
QUIT
+3 SET AUPQF=4
+4 QUIT
+5 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+6 ;
ADDPAT ; EXTERNAL ENTRY POINT - ADD PATIENT
+1 IF AUPX?1"""".E1""""
SET AUPX=$EXTRACT(AUPX,2,$LENGTH(AUPX)-1)
+2 DO ^AUPNLK2
+3 SET Y=AUPDFN
+4 IF Y<0
SET AUPQF=3
QUIT
+5 SET AUPQF=5
+6 QUIT
