AUPNLKB.m

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