BGOUTL3.m

BGOUTL3 ; IHS/BAO/TMD - Utilities (continued)  ;11-Jul-2013 13:22;du

 ;;1.1;BGO COMPONENTS;**11,13**;Mar 20, 2007;Build 13

GETSET(RET,BGOFILE,BGOFLD,BGOCHK) ;gets set of codes

 ; RET(n)=code^text for code

 N BGOPCC,BGOPCCL,BGOPCCC,BGOLO,BGOHI,BGOPCCD,BGOPCCT

 S BGOCHK=$G(BGOCHK)

 S BGOLO="abcdefghijklmnopqrstuvwxyz"

 S BGOHI="ABCDEFGHIJKLMNOPQRSTUVWXYZ"

 D FIELD^DID(BGOFILE,BGOFLD,"","POINTER","BGOPCC","BGOPCC")

 S BGOPCCL=$L(BGOPCC("POINTER"),";")-1

 F BGOPCCC=1:1:BGOPCCL D

 . S BGOPCCD=$P($P(BGOPCC("POINTER"),";",BGOPCCC),":",1)

 . S BGOPCCT=$P($P(BGOPCC("POINTER"),";",BGOPCCC),":",2)

 . I BGOCHK'="" D CHK(BGOFILE,BGOPCCD,BGOCHK)

 . I BGOCHK="" S RET(BGOPCCC)=BGOPCCD_"^"_$E(BGOPCCT)_$TR($E(BGOPCCT,2,99),BGOHI,BGOLO)

 Q

CHK(BGOFILE,BGOPCCD,BGOCHK) ;See which codes are acceptable for this file

 N IEN,C

 I BGOFILE=9000010.13 D  Q         ;EXAM FILE

 .S IEN="" S IEN=$O(^AUTTEXAM("B",BGOCHK,IEN))

 .I IEN="" S BGOCHK="" Q

 .S C=$P($G(^AUTTEXAM(IEN,0)),U,2)

 .S X=BGOPCCD

 .D EXAM

 .I $D(X) S RET(BGOPCCC)=BGOPCCD_"^"_$E(BGOPCCT)_$TR($E(BGOPCCT,2,99),BGOHI,BGOLO)

 Q

EXAM ;Check exam codes

 I X="RF" Q  ;referral good for all exam types

 I X="PA",C'=34 K X Q

 I X="PR",C'=34 K X Q

 I X="PAP",C'=34 K X Q

 I X="A",C=34 K X Q

 I X="A",C=35 K X Q

 I X="A",C=36 K X Q

 I X="PO",(C'=35&(C'=36)) K X Q

 I X="L",(C'=42&(C'=43)) K X Q

 I X="M",(C'=42&(C'=43)) K X Q

 I X="H",(C'=42&(C'=43)) K X Q

 I C=42!(C=43),X'="L",X'="M",X'="H" K X Q

 Q

BGOUTL3   ; IHS/BAO/TMD - Utilities (continued)  ;11-Jul-2013 13:22;du

 +1       ;;1.1;BGO COMPONENTS;**11,13**;Mar 20, 2007;Build 13

GETSET(RET,BGOFILE,BGOFLD,BGOCHK) ;gets set of codes

 +1       ; RET(n)=code^text for code

 +2        NEW BGOPCC,BGOPCCL,BGOPCCC,BGOLO,BGOHI,BGOPCCD,BGOPCCT

 +3        SET BGOCHK=$GET(BGOCHK)

 +4        SET BGOLO="abcdefghijklmnopqrstuvwxyz"

 +5        SET BGOHI="ABCDEFGHIJKLMNOPQRSTUVWXYZ"

 +6        DO FIELD^DID(BGOFILE,BGOFLD,"","POINTER","BGOPCC","BGOPCC")

 +7        SET BGOPCCL=$LENGTH(BGOPCC("POINTER"),";")-1

 +8        FOR BGOPCCC=1:1:BGOPCCL

               Begin DoDot:1

 +9                SET BGOPCCD=$PIECE($PIECE(BGOPCC("POINTER"),";",BGOPCCC),":",1)

 +10               SET BGOPCCT=$PIECE($PIECE(BGOPCC("POINTER"),";",BGOPCCC),":",2)

 +11               IF BGOCHK'=""

                       DO CHK(BGOFILE,BGOPCCD,BGOCHK)

 +12               IF BGOCHK=""

                       SET RET(BGOPCCC)=BGOPCCD_"^"_$EXTRACT(BGOPCCT)_$TRANSLATE($EXTRACT(BGOPCCT,2,99),BGOHI,BGOLO)

               End DoDot:1

 +13       QUIT 

CHK(BGOFILE,BGOPCCD,BGOCHK) ;See which codes are acceptable for this file

 +1        NEW IEN,C

 +2       ;EXAM FILE

           IF BGOFILE=9000010.13

               Begin DoDot:1

 +3                SET IEN=""

                   SET IEN=$ORDER(^AUTTEXAM("B",BGOCHK,IEN))

 +4                IF IEN=""

                       SET BGOCHK=""

                       QUIT 

 +5                SET C=$PIECE($GET(^AUTTEXAM(IEN,0)),U,2)

 +6                SET X=BGOPCCD

 +7                DO EXAM

 +8                IF $DATA(X)

                       SET RET(BGOPCCC)=BGOPCCD_"^"_$EXTRACT(BGOPCCT)_$TRANSLATE($EXTRACT(BGOPCCT,2,99),BGOHI,BGOLO)

               End DoDot:1

               QUIT 

 +9        QUIT 

EXAM      ;Check exam codes

 +1       ;referral good for all exam types

           IF X="RF"

               QUIT 

 +2        IF X="PA"

               IF C'=34

                   KILL X

                   QUIT 

 +3        IF X="PR"

               IF C'=34

                   KILL X

                   QUIT 

 +4        IF X="PAP"

               IF C'=34

                   KILL X

                   QUIT 

 +5        IF X="A"

               IF C=34

                   KILL X

                   QUIT 

 +6        IF X="A"

               IF C=35

                   KILL X

                   QUIT 

 +7        IF X="A"

               IF C=36

                   KILL X

                   QUIT 

 +8        IF X="PO"

               IF (C'=35&(C'=36))

                   KILL X

                   QUIT 

 +9        IF X="L"

               IF (C'=42&(C'=43))

                   KILL X

                   QUIT 

 +10       IF X="M"

               IF (C'=42&(C'=43))

                   KILL X

                   QUIT 

 +11       IF X="H"

               IF (C'=42&(C'=43))

                   KILL X

                   QUIT 

 +12       IF C=42!(C=43)

               IF X'="L"

                   IF X'="M"

                       IF X'="H"

                           KILL X

                           QUIT 

 +13       QUIT