Routine: AUPNVDXP

AUPNVDXP ; IHS/CMI/LAB - CHECKS VALUES FOR AUPNVDXP (DIAGNOSTIC PROCEDURE RESULTS 9000010.21) 24-MAY-1993 ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

N %

 S AUPNDXR=+^AUPNVDXP(DA,0) I 'AUPNDXR K X G EXIT

 S %=$G(^AUTTDXPR(AUPNDXR,0)),AUPNDXTP=$P(%,U,2),AUPNDXPM=$P(%,U,3)

 I AUPNDXTP="" K X G EXIT

 I $G(AUPNDXQF)="S" D AQ^AUPNVDXQ G EXIT

 I $G(AUPNDXQF)="K" D AQKILL^AUPNVDXQ G EXIT

 I $G(AUPNDXQF)="S1" D AQ1^AUPNVDXQ G EXIT

 I $G(AUPNDXQF)="K1" D AQKILL1^AUPNVDXQ G EXIT

 I $D(AUPNDXTF) N AUPNDXVV,AUPNDXPP D PTR D:$D(AUPNDXTF) @("TR"_AUPNDXTP) G EXIT

 ; I $D(AUPNDXTP) D TP G EXIT

 D @("IT"_AUPNDXTP)

EXIT K AUPNDXR,AUPNDXTP,AUPNDXPM,AUPNDXQF,AUPNDXTF,AUPNDXTP

ITS ; CKECKS SET OF CODES

ITG ; CHECKS GROUP

 I $G(AUPNDXPM)="" K X Q

 N A S A=";"_AUPNDXPM

 I A[(";"_X_":") Q

 ;I A[":"_X_";" S X=$P($P(A,":"_X),";",2) Q

 ;I A[(":"_X_";") S X=$P($P(A,":",X),";",2) Q

 I A[(":"_X) D  Q

 .S X=$P(A,X,1)

 .N L S L=$L(X,";")

 .S X=$P(X,";",L)

 .S X=$P(X,":",1)

K X

ITL ; CHECKS POINTER

ITN ; CHECKS NUMBERS

 N A,B,C

 I AUPNDXPM="" K X Q

 S A=$P(AUPNDXPM,";"),B=$P(AUPNDXPM,";",2),C=$P(AUPNDXPM,";",3)

 I (A'=+A)!(B'=+B) K X Q

 I X>A!(X<B) K X

 I $L($P(X,".",2))>C K X Q

HELP ;EP - HELP MESSAGE GENERATOR

 N AUPNDXDA S AUPNDXDA=DA

 N DIC,DIJ,DP,B,X,Y,P,DIA,DA

 N D,DC,DE,DG,DH,DI,DIP,DIE,DIEL,DIFLD,DK,DL,DM,DP,DQ,DR,DSC,DV,DU,DW,DXS,DZ,L

 S IOP=0,DIC="^AUTTDXPR(",FLDS=3,BY="@NUMBER",(FR,TO)=+^AUPNVDXP(AUPNDXDA,0),DHD="@"

 D EN1^DIP

TRG ;

TRL ;

TRS ; TRIGGERS SET OF CODE RESULTS

 S X=""

TRN ; TRIGGERS NUMBERS

 N A,B,C,D,% S %=AUPNDXPP

 S A=$P(%,";"),B=$P(%,";",2),C=$P(%,";",3),D=$P(%,";",4)

 I (A'=+A)!(B'=+B)!(C'=+C)!(D'=+D) S X="" Q

 S %=AUPNDXVV,X=$S(%>C:"H*",%<D:"L*",%>A:"H",%<B:"L",1:"")

TP ; TRIGGER PARAMS INTO PARAMS FIELD

 N Z,% S %=$P($G(APCDTRQ),"~",2,9),Z=$G(AUPNDXPM)

 I Z=""!(%="") S X="" Q

 S X=$TR(%,"~",";")_";"_$P(AUPNDXPM,";",4)

PTR S X="" N %

 I '$G(DA) Q

 S %=$G(^AUPNVDXP(DA,0))

 S AUPNDXVV=$P(%,U,4),AUPNDXPP=$P(%,U,6)

 I AUPNDXVV=""!(AUPNDXPP)="" K AUPNDXTF Q

AUPNVDXP  ; IHS/CMI/LAB - CHECKS VALUES FOR AUPNVDXP (DIAGNOSTIC PROCEDURE RESULTS 9000010.21) 24-MAY-1993 ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2        NEW %

 +3        SET AUPNDXR=+^AUPNVDXP(DA,0)

           IF 'AUPNDXR

               KILL X

               GOTO EXIT

 +4        SET %=$GET(^AUTTDXPR(AUPNDXR,0))

           SET AUPNDXTP=$PIECE(%,U,2)

           SET AUPNDXPM=$PIECE(%,U,3)

 +5        IF AUPNDXTP=""

               KILL X

               GOTO EXIT

 +6        IF $GET(AUPNDXQF)="S"

               DO AQ^AUPNVDXQ

               GOTO EXIT

 +7        IF $GET(AUPNDXQF)="K"

               DO AQKILL^AUPNVDXQ

               GOTO EXIT

 +8        IF $GET(AUPNDXQF)="S1"

               DO AQ1^AUPNVDXQ

               GOTO EXIT

 +9        IF $GET(AUPNDXQF)="K1"

               DO AQKILL1^AUPNVDXQ

               GOTO EXIT

 +10       IF $DATA(AUPNDXTF)

               NEW AUPNDXVV,AUPNDXPP

               DO PTR

               IF $DATA(AUPNDXTF)

                   DO @("TR"_AUPNDXTP)

               GOTO EXIT

 +11      ; I $D(AUPNDXTP) D TP G EXIT

 +12       DO @("IT"_AUPNDXTP)

EXIT       KILL AUPNDXR,AUPNDXTP,AUPNDXPM,AUPNDXQF,AUPNDXTF,AUPNDXTP

 +1        QUIT

 +2       ;

ITS       ; CKECKS SET OF CODES

ITG       ; CHECKS GROUP

 +1        IF $GET(AUPNDXPM)=""

               KILL X

               QUIT

 +2        NEW A

           SET A=";"_AUPNDXPM

 +3        IF A[(";"_X_":")

               QUIT

 +4       ;I A[":"_X_";" S X=$P($P(A,":"_X),";",2) Q

 +5       ;I A[(":"_X_";") S X=$P($P(A,":",X),";",2) Q

 +6        IF A[(":"_X)

               Begin DoDot:1

 +7                SET X=$PIECE(A,X,1)

 +8                NEW L

                   SET L=$LENGTH(X,";")

 +9                SET X=$PIECE(X,";",L)

 +10               SET X=$PIECE(X,":",1)

               End DoDot:1

               QUIT

 +11       KILL X

 +12       QUIT

 +13      ;

ITL       ; CHECKS POINTER

 +1        QUIT

 +2       ;

ITN       ; CHECKS NUMBERS

 +1        NEW A,B,C

 +2        IF AUPNDXPM=""

               KILL X

               QUIT

 +3        SET A=$PIECE(AUPNDXPM,";")

           SET B=$PIECE(AUPNDXPM,";",2)

           SET C=$PIECE(AUPNDXPM,";",3)

 +4        IF (A'=+A)!(B'=+B)

               KILL X

               QUIT

 +5        IF X>A!(X<B)

               KILL X

 +6        IF $LENGTH($PIECE(X,".",2))>C

               KILL X

               QUIT

 +7        QUIT

 +8       ;

HELP      ;EP - HELP MESSAGE GENERATOR

 +1        NEW AUPNDXDA

           SET AUPNDXDA=DA

 +2        NEW DIC,DIJ,DP,B,X,Y,P,DIA,DA

 +3        NEW D,DC,DE,DG,DH,DI,DIP,DIE,DIEL,DIFLD,DK,DL,DM,DP,DQ,DR,DSC,DV,DU,DW,DXS,DZ,L

 +4        SET IOP=0

           SET DIC="^AUTTDXPR("

           SET FLDS=3

           SET BY="@NUMBER"

           SET (FR,TO)=+^AUPNVDXP(AUPNDXDA,0)

           SET DHD="@"

 +5        DO EN1^DIP

 +6        QUIT

 +7       ;

TRG       ;

TRL       ;

TRS       ; TRIGGERS SET OF CODE RESULTS

 +1        SET X=""

 +2        QUIT

 +3       ;

TRN       ; TRIGGERS NUMBERS

 +1        NEW A,B,C,D,%

           SET %=AUPNDXPP

 +2        SET A=$PIECE(%,";")

           SET B=$PIECE(%,";",2)

           SET C=$PIECE(%,";",3)

           SET D=$PIECE(%,";",4)

 +3        IF (A'=+A)!(B'=+B)!(C'=+C)!(D'=+D)

               SET X=""

               QUIT

 +4        SET %=AUPNDXVV

           SET X=$SELECT(%>C:"H*",%<D:"L*",%>A:"H",%<B:"L",1:"")

 +5        QUIT

 +6       ;

TP        ; TRIGGER PARAMS INTO PARAMS FIELD

 +1        NEW Z,%

           SET %=$PIECE($GET(APCDTRQ),"~",2,9)

           SET Z=$GET(AUPNDXPM)

 +2        IF Z=""!(%="")

               SET X=""

               QUIT

 +3        SET X=$TRANSLATE(%,"~",";")_";"_$PIECE(AUPNDXPM,";",4)

 +4        QUIT

 +5       ;

PTR        SET X=""

           NEW %

 +1        IF '$GET(DA)

               QUIT

 +2        SET %=$GET(^AUPNVDXP(DA,0))

 +3        SET AUPNDXVV=$PIECE(%,U,4)

           SET AUPNDXPP=$PIECE(%,U,6)

 +4        IF AUPNDXVV=""!(AUPNDXPP)=""

               KILL AUPNDXTF

               QUIT

AUPNVDXP.m