AUPNLK1 ; IHS/CMI/LAB - IHS PATIENT LOOKUP CHECK XREFS ;
;;99.1;IHS DICTIONARIES (PATIENT);;MAR 09, 1999
;'Modified' MAS Patient Look-up Check Cross-References June 1987
;
; Upon exiting this routine AUPDFN will exist as follows:
; AUPDFN = 0 means no hits
; AUPDFN < 0 means hits but no selection
; AUPDFN > 0 means selection made
;
START ;
D INIT ; Fix up AUPX & set up xrefs
D SEARCH ; Search xrefs
D EOJ ; Cleanup
Q
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
SEARCH ; SEARCH XREFS
F AUPLP=1:1 S AUPREF=$P(AUPREFS,",",AUPLP) Q:AUPREF=""!(AUPDFN) S AUPVAL=$S(AUPREF="ADOB":AUPDT,1:AUPX) D IHSVAL I 'AUPDFN,AUPREF="B" D IHSB I 'AUPDFN D IHSCHK
I 'AUPDFN S:AUPCNT=1&($D(AUPIFNS(AUPCNT))) AUPDFN=+AUPIFNS(AUPCNT) S AUP("NOPRT^")="" D PRTAUP^AUPNLKUT:'AUPDFN&(AUPCNT>AUPNUM)&(DIC(0)["E") K AUP("NOPRT^") I 'AUPDFN,$D(AUPSEL),AUPSEL="" S AUPX="",AUPDFN=-1
Q
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
IHSB ; CHECK TRANSPOSED OR MISSING FIRST/MIDDLE
Q:AUPX'?1A.E1",".E
S AUPNML=$P(AUPX,",",1),AUPNMF=$P($P(AUPX,",",2)," ",1),AUPNMM=$P($P(AUPX,",",2)," ",2)
Q:AUPNMF=""
I AUPNMF?.E1P.E S X=AUPNMF D PUNC S AUPNMF=X
I AUPNMM?.E1P.E S X=AUPNMM D PUNC S AUPNMM=X
S AUPBX=AUPNML
F AUPBI=0:0 Q:AUPDFN S AUPBX=$O(^DPT("B",AUPBX)) Q:$P($P(AUPBX,",",1)," ",1)'=AUPNML S AUPBY=$P(AUPBX,",",2) D IHSB2 I Y F Y=0:0 S Y=$O(^DPT("B",AUPBX,Y)) Q:'Y I '$D(AUPS(Y)) S AUPVAL=AUPBX,AUPNICK(Y)="" D SETAUP^AUPNLKUT Q:AUPDFN
K AUPBI,AUPBX,AUPBY
Q
;
PUNC ;
F I=1:1:$L(X) I $E(X,I)?1P S X=$E(X,1,I-1)_$E(X,I+1,99)
Q
;
IHSB2 ;
S Y=0
I " "_$P(AUPBY," ",2)[(" "_AUPNMF)," "_$P(AUPBY," ",1)[(" "_AUPNMM) S Y=1 Q
I " "_$P(AUPBY," ",1)[(" "_AUPNMF)," "_$P(AUPBY," ",2)[(" "_AUPNMM) S Y=1 Q
Q
;
IHSCHK ; CHECK NICKNAMES AND LAST NAME FOR MISPELLING
Q:AUPX'?1A.E1",".E
S AUPNMCVN=3
D IHSCHK4
Q:AUPDFN
S AUPNMCHK("AUPX")=AUPX
S AUPNMCHK("LAST")=$P(AUPX,",",1)
I $D(^APMM(98,"B",AUPNMCHK("LAST"))) F AUPNMCHK("EN")=0:0 S AUPNMCHK("EN")=$O(^APMM(98,"B",AUPNMCHK("LAST"),AUPNMCHK("EN"))) Q:AUPNMCHK("EN")="" D IHSCHK2 Q:AUPDFN
S AUPX=AUPNMCHK("AUPX")
K AUPNMCHK,AUPNMCVN
Q
;
IHSCHK2 ;
K AUPNMCHK("TBL")
S AUPNMCHK("TBL",$P(^APMM(98,AUPNMCHK("EN"),0),U,1))=""
F AUPL=0:0 S AUPL=$O(^APMM(98,AUPNMCHK("EN"),"F",AUPL)) Q:AUPL'=+AUPL S AUPNMCHK("TBL",$P(^APMM(98,AUPNMCHK("EN"),"F",AUPL,0),U,1))=""
K AUPNMCHK("TBL",$P(AUPNMCHK("AUPX"),U,1))
S AUPNMCHK("NLAST")="" F AUPL=0:0 S AUPNMCHK("NLAST")=$O(AUPNMCHK("TBL",AUPNMCHK("NLAST"))) Q:AUPNMCHK("NLAST")="" D IHSCHK3 Q:AUPDFN
Q
;
IHSCHK3 ;
S $P(AUPX,",",1)=AUPNMCHK("NLAST"),AUPVAL=AUPX
S AUPNMCVN=3
D IHSVAL
Q:AUPDFN
D IHSCHK4
Q
;
IHSCHK4 ; CHECK FIRST & MIDDLE NAMES FOR NICK NAMES
S AUPNML=$P(AUPX,",",1),AUPNMF=$P($P(AUPX,",",2)," ",1),AUPNMM=$P($P(AUPX,",",2)," ",2)
Q:AUPNMF=""
I $D(^APMM(99,"B",AUPNMF)) S AUPNMCVN=1 F AUPNMCV=0:0 S AUPNMCV=$O(^APMM(99,"B",AUPNMF,AUPNMCV)) Q:AUPNMCV="" D IHSNMCV Q:AUPDFN
K AUPNMCV,AUPNMCVT
Q:AUPDFN
I AUPNMM'="",$D(^APMM(99,"B",AUPNMM)) S AUPNMCVN=2 F AUPNMCV=0:0 S AUPNMCV=$O(^APMM(99,"B",AUPNMM,AUPNMCV)) Q:AUPNMCV="" D IHSNMCV Q:AUPDFN
K AUPNMCV,AUPNMCVN,AUPNMCVT
Q:AUPDFN
K AUPNML,AUPNMF,AUPNMM
Q
;
IHSNMCV ; CHECK NICK NAMES
K AUPNMCVT
S AUPNMCVT($P(^APMM(99,AUPNMCV,0),U,1))=""
F AUPL=0:0 S AUPL=$O(^APMM(99,AUPNMCV,"F",AUPL)) Q:AUPL'=+AUPL S AUPNMCVT($P(^APMM(99,AUPNMCV,"F",AUPL,0),U,1))=""
K AUPNMCVT($S(AUPNMCVN=1:AUPNMF,1:AUPNMM))
S AUPNMCVI="" F AUPL=0:0 S AUPNMCVI=$O(AUPNMCVT(AUPNMCVI)) Q:AUPNMCVI=""!(AUPDFN) S AUPVAL=AUPNML_","_$S(AUPNMCVN=1:AUPNMCVI,1:AUPNMF)_$S(AUPNMCVN=1&(AUPNMM'=""):" "_AUPNMM,AUPNMCVN=2:" "_AUPNMCVI,1:"") D IHSNMCV2
K AUPNMCVI
Q
;
IHSNMCV2 ;
S AUPNMCVX=AUPX,AUPX=AUPVAL
D IHSVAL
S AUPX=AUPNMCVX
K AUPNMCVX
Q
;
IHSVAL ;
I $D(^DPT(AUPREF,AUPVAL))&(DIC(0)["X") D CHKIFN Q
D:$D(^DPT(AUPREF,AUPVAL)) CHKIFN
D:DIC(0)'["X" CHKVAL
Q
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
CHKVAL ;
S AUPVAL=$S($D(AUPNMCVN):AUPVAL,AUPREF="ADOB":AUPDT,AUPX?.N:AUPX_" ",1:AUPX) S:$E(AUPVAL,$L(AUPVAL))="." AUPVAL=$E(AUPVAL,1,$L(AUPVAL)-1)
F AUPLP1=0:0 S AUPVAL=$O(^DPT(AUPREF,AUPVAL)) Q:AUPVAL=""!(AUPDFN)!($P(AUPVAL,$S($E(AUPX,$L(AUPX))=".":$E(AUPX,1,$L(AUPX)-1),1:AUPX))'="") D CHKIFN
Q
;
CHKIFN ;
F AUPIFN=0:0 S AUPIFN=$O(^DPT(AUPREF,AUPVAL,AUPIFN)) Q:'AUPIFN!(AUPDFN) S Y=AUPIFN D SETAUP^AUPNLKUT I $S<1000 F AUPI=1:1:AUPNUM-5 Q:'$D(AUPIFNS(AUPI)) K AUPIFNS(AUPI) S AUPBEG=AUPI
Q
;
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
INIT ; INITIALIZATION - FIX UP AUPX AND SET UP XREFS
D ^AUPNLK1I
Q
;
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
EOJ ;
K AUPBEG,AUPDT,AUPI,AUPIFN,AUPIFNS,AUPLP,AUPLK1,AUPNMCHK,AUPNMCV,AUPNMCVN,AUPNMCVT,AUPNMF,AUPNML,AUPNMM,AUPNUM,AUPREF,AUPREFS,AUPVAL
Q
AUPNLK1 ; IHS/CMI/LAB - IHS PATIENT LOOKUP CHECK XREFS ;
+1 ;;99.1;IHS DICTIONARIES (PATIENT);;MAR 09, 1999
+2 ;'Modified' MAS Patient Look-up Check Cross-References June 1987
+3 ;
+4 ; Upon exiting this routine AUPDFN will exist as follows:
+5 ; AUPDFN = 0 means no hits
+6 ; AUPDFN < 0 means hits but no selection
+7 ; AUPDFN > 0 means selection made
+8 ;
START ;
+1 ; Fix up AUPX & set up xrefs
DO INIT
+2 ; Search xrefs
DO SEARCH
+3 ; Cleanup
DO EOJ
+4 QUIT
+5 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+6 ;
SEARCH ; SEARCH XREFS
+1 FOR AUPLP=1:1
SET AUPREF=$PIECE(AUPREFS,",",AUPLP)
IF AUPREF=""!(AUPDFN)
QUIT
SET AUPVAL=$SELECT(AUPREF="ADOB":AUPDT,1:AUPX)
DO IHSVAL
IF 'AUPDFN
IF AUPREF="B"
DO IHSB
IF 'AUPDFN
DO IHSCHK
+2 IF 'AUPDFN
IF AUPCNT=1&($DATA(AUPIFNS(AUPCNT)))
SET AUPDFN=+AUPIFNS(AUPCNT)
SET AUP("NOPRT^")=""
IF 'AUPDFN&(AUPCNT>AUPNUM)&(DIC(0)["E")
DO PRTAUP^AUPNLKUT
KILL AUP("NOPRT^")
IF 'AUPDFN
IF $DATA(AUPSEL)
IF AUPSEL=""
SET AUPX=""
SET AUPDFN=-1
+3 QUIT
+4 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+5 ;
IHSB ; CHECK TRANSPOSED OR MISSING FIRST/MIDDLE
+1 IF AUPX'?1A.E1",".E
QUIT
+2 SET AUPNML=$PIECE(AUPX,",",1)
SET AUPNMF=$PIECE($PIECE(AUPX,",",2)," ",1)
SET AUPNMM=$PIECE($PIECE(AUPX,",",2)," ",2)
+3 IF AUPNMF=""
QUIT
+4 IF AUPNMF?.E1P.E
SET X=AUPNMF
DO PUNC
SET AUPNMF=X
+5 IF AUPNMM?.E1P.E
SET X=AUPNMM
DO PUNC
SET AUPNMM=X
+6 SET AUPBX=AUPNML
+7 FOR AUPBI=0:0
IF AUPDFN
QUIT
SET AUPBX=$ORDER(^DPT("B",AUPBX))
IF $PIECE($PIECE(AUPBX,",",1)," ",1)'=AUPNML
QUIT
SET AUPBY=$PIECE(AUPBX,",",2)
DO IHSB2
IF Y
FOR Y=0:0
SET Y=$ORDER(^DPT("B",AUPBX,Y))
IF 'Y
QUIT
IF '$DATA(AUPS(Y))
SET AUPVAL=AUPBX
SET AUPNICK(Y)=""
DO SETAUP^AUPNLKUT
IF AUPDFN
QUIT
+8 KILL AUPBI,AUPBX,AUPBY
+9 QUIT
+10 ;
PUNC ;
+1 FOR I=1:1:$LENGTH(X)
IF $EXTRACT(X,I)?1P
SET X=$EXTRACT(X,1,I-1)_$EXTRACT(X,I+1,99)
+2 QUIT
+3 ;
IHSB2 ;
+1 SET Y=0
+2 IF " "_$PIECE(AUPBY," ",2)[(" "_AUPNMF)
IF " "_$PIECE(AUPBY," ",1)[(" "_AUPNMM)
SET Y=1
QUIT
+3 IF " "_$PIECE(AUPBY," ",1)[(" "_AUPNMF)
IF " "_$PIECE(AUPBY," ",2)[(" "_AUPNMM)
SET Y=1
QUIT
+4 QUIT
+5 ;
IHSCHK ; CHECK NICKNAMES AND LAST NAME FOR MISPELLING
+1 IF AUPX'?1A.E1",".E
QUIT
+2 SET AUPNMCVN=3
+3 DO IHSCHK4
+4 IF AUPDFN
QUIT
+5 SET AUPNMCHK("AUPX")=AUPX
+6 SET AUPNMCHK("LAST")=$PIECE(AUPX,",",1)
+7 IF $DATA(^APMM(98,"B",AUPNMCHK("LAST")))
FOR AUPNMCHK("EN")=0:0
SET AUPNMCHK("EN")=$ORDER(^APMM(98,"B",AUPNMCHK("LAST"),AUPNMCHK("EN")))
IF AUPNMCHK("EN")=""
QUIT
DO IHSCHK2
IF AUPDFN
QUIT
+8 SET AUPX=AUPNMCHK("AUPX")
+9 KILL AUPNMCHK,AUPNMCVN
+10 QUIT
+11 ;
IHSCHK2 ;
+1 KILL AUPNMCHK("TBL")
+2 SET AUPNMCHK("TBL",$PIECE(^APMM(98,AUPNMCHK("EN"),0),U,1))=""
+3 FOR AUPL=0:0
SET AUPL=$ORDER(^APMM(98,AUPNMCHK("EN"),"F",AUPL))
IF AUPL'=+AUPL
QUIT
SET AUPNMCHK("TBL",$PIECE(^APMM(98,AUPNMCHK("EN"),"F",AUPL,0),U,1))=""
+4 KILL AUPNMCHK("TBL",$PIECE(AUPNMCHK("AUPX"),U,1))
+5 SET AUPNMCHK("NLAST")=""
FOR AUPL=0:0
SET AUPNMCHK("NLAST")=$ORDER(AUPNMCHK("TBL",AUPNMCHK("NLAST")))
IF AUPNMCHK("NLAST")=""
QUIT
DO IHSCHK3
IF AUPDFN
QUIT
+6 QUIT
+7 ;
IHSCHK3 ;
+1 SET $PIECE(AUPX,",",1)=AUPNMCHK("NLAST")
SET AUPVAL=AUPX
+2 SET AUPNMCVN=3
+3 DO IHSVAL
+4 IF AUPDFN
QUIT
+5 DO IHSCHK4
+6 QUIT
+7 ;
IHSCHK4 ; CHECK FIRST & MIDDLE NAMES FOR NICK NAMES
+1 SET AUPNML=$PIECE(AUPX,",",1)
SET AUPNMF=$PIECE($PIECE(AUPX,",",2)," ",1)
SET AUPNMM=$PIECE($PIECE(AUPX,",",2)," ",2)
+2 IF AUPNMF=""
QUIT
+3 IF $DATA(^APMM(99,"B",AUPNMF))
SET AUPNMCVN=1
FOR AUPNMCV=0:0
SET AUPNMCV=$ORDER(^APMM(99,"B",AUPNMF,AUPNMCV))
IF AUPNMCV=""
QUIT
DO IHSNMCV
IF AUPDFN
QUIT
+4 KILL AUPNMCV,AUPNMCVT
+5 IF AUPDFN
QUIT
+6 IF AUPNMM'=""
IF $DATA(^APMM(99,"B",AUPNMM))
SET AUPNMCVN=2
FOR AUPNMCV=0:0
SET AUPNMCV=$ORDER(^APMM(99,"B",AUPNMM,AUPNMCV))
IF AUPNMCV=""
QUIT
DO IHSNMCV
IF AUPDFN
QUIT
+7 KILL AUPNMCV,AUPNMCVN,AUPNMCVT
+8 IF AUPDFN
QUIT
+9 KILL AUPNML,AUPNMF,AUPNMM
+10 QUIT
+11 ;
IHSNMCV ; CHECK NICK NAMES
+1 KILL AUPNMCVT
+2 SET AUPNMCVT($PIECE(^APMM(99,AUPNMCV,0),U,1))=""
+3 FOR AUPL=0:0
SET AUPL=$ORDER(^APMM(99,AUPNMCV,"F",AUPL))
IF AUPL'=+AUPL
QUIT
SET AUPNMCVT($PIECE(^APMM(99,AUPNMCV,"F",AUPL,0),U,1))=""
+4 KILL AUPNMCVT($SELECT(AUPNMCVN=1:AUPNMF,1:AUPNMM))
+5 SET AUPNMCVI=""
FOR AUPL=0:0
SET AUPNMCVI=$ORDER(AUPNMCVT(AUPNMCVI))
IF AUPNMCVI=""!(AUPDFN)
QUIT
SET AUPVAL=AUPNML_","_$SELECT(AUPNMCVN=1:AUPNMCVI,1:AUPNMF)_$SELECT(AUPNMCVN=1&(AUPNMM'=""):" "_AUPNMM,AUPNMCVN=2:" "_AUPNMCVI,1:"")
DO IHSNMCV2
+6 KILL AUPNMCVI
+7 QUIT
+8 ;
IHSNMCV2 ;
+1 SET AUPNMCVX=AUPX
SET AUPX=AUPVAL
+2 DO IHSVAL
+3 SET AUPX=AUPNMCVX
+4 KILL AUPNMCVX
+5 QUIT
+6 ;
IHSVAL ;
+1 IF $DATA(^DPT(AUPREF,AUPVAL))&(DIC(0)["X")
DO CHKIFN
QUIT
+2 IF $DATA(^DPT(AUPREF,AUPVAL))
DO CHKIFN
+3 IF DIC(0)'["X"
DO CHKVAL
+4 QUIT
+5 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+6 ;
CHKVAL ;
+1 SET AUPVAL=$SELECT($DATA(AUPNMCVN):AUPVAL,AUPREF="ADOB":AUPDT,AUPX?.N:AUPX_" ",1:AUPX)
IF $EXTRACT(AUPVAL,$LENGTH(AUPVAL))="."
SET AUPVAL=$EXTRACT(AUPVAL,1,$LENGTH(AUPVAL)-1)
+2 FOR AUPLP1=0:0
SET AUPVAL=$ORDER(^DPT(AUPREF,AUPVAL))
IF AUPVAL=""!(AUPDFN)!($PIECE(AUPVAL,$SELECT($EXTRACT(AUPX,$LENGTH(AUPX))="."
QUIT
DO CHKIFN
+3 QUIT
+4 ;
CHKIFN ;
+1 FOR AUPIFN=0:0
SET AUPIFN=$ORDER(^DPT(AUPREF,AUPVAL,AUPIFN))
IF 'AUPIFN!(AUPDFN)
QUIT
SET Y=AUPIFN
DO SETAUP^AUPNLKUT
IF $STORAGE<1000
FOR AUPI=1:1:AUPNUM-5
IF '$DATA(AUPIFNS(AUPI))
QUIT
KILL AUPIFNS(AUPI)
SET AUPBEG=AUPI
+2 QUIT
+3 ;
+4 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+5 ;
INIT ; INITIALIZATION - FIX UP AUPX AND SET UP XREFS
+1 DO ^AUPNLK1I
+2 QUIT
+3 ;
+4 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+5 ;
EOJ ;
+1 KILL AUPBEG,AUPDT,AUPI,AUPIFN,AUPIFNS,AUPLP,AUPLK1,AUPNMCHK,AUPNMCV,AUPNMCVN,AUPNMCVT,AUPNMF,AUPNML,AUPNMM,AUPNUM,AUPREF,AUPREFS,AUPVAL
+2 QUIT
