AUPNLK1.m

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