Routine: BLRMPRL2

BLRMPRL2 ; IHS/MSC/MKK - BLR Map Reference Lab Codes to Lab Test File - version 2 ; 01-Jun-2016 13:35 ; MKK

 ;;5.2;LR;**1039**;NOV 01, 1997;Build 38

EEP ; Ersatz EP

 D EEP^BLRGMENU

 ; Cloned from BLRMPRL

 ; This routine will allow a user to map BLR Reference Lab (#9009026) file tests

 ; to LABORATORY TEST (#60) file tests

EP ; EP

PEP ; PEP

 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)

 D SETBLRVS

 D ADDTMENU^BLRGMENU("MAPTESTS^BLRMPRL2","Map Reference Lab Tests")

 D ADDTMENU^BLRGMENU("MAPRPT^BLRMPRL2","Mapped Tests Report")

 D ADDTMENU^BLRGMENU("UMAPRPT^BLRMPRL2","Non-Mapped Tests Report")

 D MENUDRVR^BLRGMENU("RPMS Lab","Reference Lab Mapping")

MAPTESTS ; EP - main routine driver

 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)

 D SETBLRVS("MAPTESTS")

 S HEADER(1)="BLR Reference Lab File (#9009026)"

 S HEADER(2)="Mapping File 9009026 Tests to File 60 Tests"

 F  Q:$$ASK(.BLRRL)="Q"  D

 . S MAPPED=0

 . K HEADER(3)

 . S HEADER(3)=$$CJ^XLFSTR("Reference Lab: "_$$GET1^DIQ(9009026,BLRRL,.01),IOM)

 . D ORR(BLRRL)

 . I MAPPED D

 .. D HEADERDT^BLRGMENU

 .. W !!,?4,MAPPED," 9009026 Test",$S(MAPPED=1:"",1:"s")," Mapped."

 .. D PRESSKEY^BLRGMENU(9)

 . K HEADER(3)

ASK(BLRRL) ;-- Ask which Reference Lab to map

 D HEADERDT^BLRGMENU

 ; Get the Reference Labs in the BLR REFERENCE LAB file and create DIR array

 D ^XBFMK

 S TAB=$J("",5),TAB2=TAB_TAB

 S DIR("L")=""

 S DIR("L",1)=TAB_"Reference Labs in BLR REFERENCE LAB (#9009026) File:"

 S DIR("L",2)=""

 S LINE=2

 S RLD0=.9999999,CNT=0,SELSTR="SO^"

 F  S RLD0=$O(^BLRRL(RLD0))  Q:RLD0<1  D

 . S CNT=CNT+1

 . S RLIEN(CNT)=RLD0

 . S REFLABN=$$GET1^DIQ(9009026,RLD0,.01)

 . S SELSTR=SELSTR_CNT_":"_$P(REFLABN," ")_";"

 . S LINE=LINE+1

 . S DIR("L",LINE)=TAB2_$J(CNT,2)_")  "_REFLABN

 S SELSTR=$E(SELSTR,1,$L(SELSTR)-1)      ; Remove trailing semi-colon

 S DIR("A")=TAB_"Select Reference Lab"

 S DIR(0)=SELSTR

 D ^DIR

 I +$G(DIRUT)!(+$G(Y)<1) Q "Q"

 S BLRRL=RLIEN(Y)

 Q "OK"

ORR(RL) ; EP - ask and map Reference Lab test(s)

 S ONGO="YES"

 F  Q:ONGO="NO"  D

 . D HEADERDT^BLRGMENU

 . D ^XBFMK

 . K BLROR

 . S DIC="^BLRRL("_BLRRL_",1,",DA(1)=RL,DIC(0)="AELMQZ"

 . S DIC("A")="Select Reference Lab (#9009026) File's Test to Map: "

 . D ^DIC

 . I Y<0 S ONGO="NO"  Q

. ;

 . W !

. ;

 . S BLROR=+Y

 . ; S DIE=DIC,DA=BLROR,DR=".01:10"  ;added edit of .01 at DKR request 2/3/2006 3/24/2006 added field 10

 . S DIE=DIC,DA=BLROR,DR=".02:10"   ; Do NOT allow editing of .01 field

 . D ^DIE

 . S MAPPED=MAPPED+1

MAPRPT ; EP - Mapped Tests' Report

 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)

 Q:$$MAPRPTI()="Q"

 F  S TESTNAME=$O(^BLRRL(BLRRL,1,"B",TESTNAME))  Q:TESTNAME=""!(QFLG="Q")  D

 . S RLD1=0

 . F  S RLD1=$O(^BLRRL(BLRRL,1,"B",TESTNAME,RLD1))  Q:RLD1<1!(QFLG="Q")  D MAPRPTL

 W !!,?4,CNT," Tests",!!

 D ^%ZISC

 D PRESSKEY^BLRGMENU(9)

MAPRPTI() ; EP - Initialization

 D SETBLRVS("MAPRPT")

 S HEADER(1)="BLR Reference Lab File (#9009026)"

 Q:$$ASK(.BLRRL)="Q" "Q"

 D HEADERDT^BLRGMENU

 D HEADONE^BLRGMENU(.HDRONE)

 S HEADER(2)="Reference Lab: "_$$GET1^DIQ(9009026,BLRRL,.01)

 S HEADER(3)=$$CJ^XLFSTR("Mapped Tests",IOM)

 D HEADERDT^BLRGMENU

 D ^%ZIS

 Q:POP $$BADSTUFQ^BLRUTIL7("Quit or Invalid Device Entered.")

 U IO

 S HEADER(4)=" "

 S HEADER(5)=$$COLHEAD^BLRGMENU("File 9009026",22)

 S $E(HEADER(5),25)=$$COLHEAD^BLRGMENU("File 60",32)

 S $E(HEADER(5),60)="Order"

 S $E(HEADER(5),70)="Result"

 S HEADER(6)="Test Name"

 S $E(HEADER(6),25)="IEN"

 S $E(HEADER(6),35)="Description"

 S $E(HEADER(6),60)="Code"

 S $E(HEADER(6),70)="Code"

 S MAXLINES=IOSL-4,LINES=MAXLINES+10

 S (CNT,PG)=0

 S QFLG="NO"

 S TESTNAME=""

 Q "OK"

MAPRPTL ; EP - Line of Data

 Q:$$MAPRPTB()="Q"

 I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)  Q:QFLG="Q"

 W $E(TESTNAME,1,22)

 W ?24,F60IEN

 W ?34,F60DESC

 W ?59,ORDCODE

 W ?69,RESULTC

W !

 S LINES=LINES+1

 S CNT=CNT+1

MAPRPTB() ; EP - Break out data

 S RLD1IEN=RLD1_","_BLRRL

 S F60IEN=$$GET1^DIQ(9009026.01,RLD1IEN,.02,"I")

 Q:+F60IEN<1 "Q"

 S F60DESC=$E($$GET1^DIQ(9009026.01,RLD1IEN,.02),1,22)

 S ORDCODE=$$GET1^DIQ(9009026.01,RLD1IEN,.03)

 S RESULTC=$$GET1^DIQ(9009026.01,RLD1IEN,.04)

 Q "OK"

UMAPRPT ; EP - Un-Mapped Tests' Report

 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)

 Q:$$UMAPRPTI()="Q"

 F  S TESTNAME=$O(^BLRRL(BLRRL,1,"B",TESTNAME))  Q:TESTNAME=""!(QFLG="Q")  D

 . S RLD1=0

 . F  S RLD1=$O(^BLRRL(BLRRL,1,"B",TESTNAME,RLD1))  Q:RLD1<1!(QFLG="Q")  D UMAPRPTL

 W !!,?4,CNT," Tests",!!

 D ^%ZISC

 D PRESSKEY^BLRGMENU(9)

UMAPRPTI() ; EP - Initialization

 D SETBLRVS("UMAPRPT")

 S HEADER(1)="BLR Reference Lab File (#9009026)"

 Q:$$ASK(.BLRRL)="Q" "Q"

 D HEADERDT^BLRGMENU

 D HEADONE^BLRGMENU(.HDRONE)

 S HEADER(2)="Reference Lab: "_$$GET1^DIQ(9009026,BLRRL,.01)

 S HEADER(3)=$$CJ^XLFSTR("Non-Mapped Tests",IOM)

 D HEADERDT^BLRGMENU

 D ^%ZIS

 Q:POP $$BADSTUFQ^BLRUTIL7("Quit or Invalid Device Entered.")

 U IO

 S HEADER(4)=" "

 S $E(HEADER(5),60)="Order"

 S $E(HEADER(5),70)="Result"

 S HEADER(6)="File 9009026 Test Name"

 S $E(HEADER(6),60)="Code"

 S $E(HEADER(6),70)="Code"

 S MAXLINES=IOSL-4,LINES=MAXLINES+10

 S (CNT,PG)=0

 S QFLG="NO"

 S TESTNAME=""

 Q "OK"

UMAPRPTL ; EP - Line of Data

 Q:$$UMAPRPTB()="Q"

 I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)  Q:QFLG="Q"

 W $S($L($TR(TESTNAME," ")):$E(TESTNAME,1,22),1:"<"_RLD1_">")

 W ?59,ORDCODE

 W ?69,RESULTC

W !

 S LINES=LINES+1

 S CNT=CNT+1

UMAPRPTB() ; EP - Break out data

 S RLD1IEN=RLD1_","_BLRRL

 Q:+$$GET1^DIQ(9009026.01,RLD1IEN,.02,"I") "Q"

 S ORDCODE=$$GET1^DIQ(9009026.01,RLD1IEN,.03)

 S RESULTC=$$GET1^DIQ(9009026.01,RLD1IEN,.04)

 Q "OK"

 ; ============================= UTILITIES =============================

JUSTNEW ; EP - Generic RPMS EXCLUSIVE NEW

 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)

SETBLRVS(TWO) ; EP - Set the BLRVERN variable(s)

 K BLRVERN,BLRVERN2

 S BLRVERN=$P($P($T(+1),";")," ")

 S:$L($G(TWO)) BLRVERN2=$G(TWO)

TESTASK ; EP - Test the ASK function

 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)

 D SETBLRVS

 S HEADER(1)="BLR Reference Lab (#9009026)"

 S HEADER(2)="Mapping File 9009026 Tests to File 60 Tests"

 Q:$$ASK(.BLRRL)="Q"

 W !!,?4,"BLRRL:",BLRRL,!

 W ?9,$$GET1^DIQ(9009026,BLRRL,.01),!!

TFIELDS ; EP - Test asking fields

 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)

 D ^XBFMK

 S DIR(0)="PO^60:EMZ"

 D ^DIR

 I +$G(DIRUT)!(+Y<1) Q

 K FDA,ERRS

 S FDA(9009026.01,"1,1,",.02)=+Y

 D UPDATE^DIE("S","FDA",,"ERRS")

 D ^XBFMK

 ; Use Quest as the Ref Lab

 S (BLRRL,BLROR,RL)=1

 S DIC="^BLRRL("_BLRRL_",1,",DA(1)=RL,DIC(0)="AELMQZ"

 S DIE=DIC,DA=BLROR,DR=".03:10"   ; Do NOT allow editing of .01 field

 D ^DIE

 S MAPPED=MAPPED+1

BLRMPRL2  ; IHS/MSC/MKK - BLR Map Reference Lab Codes to Lab Test File - version 2 ; 01-Jun-2016 13:35 ; MKK

 +1       ;;5.2;LR;**1039**;NOV 01, 1997;Build 38

 +2       ;

EEP       ; Ersatz EP

 +1        DO EEP^BLRGMENU

 +2        QUIT

 +3       ;

 +4       ; Cloned from BLRMPRL

 +5       ;

 +6       ; This routine will allow a user to map BLR Reference Lab (#9009026) file tests

 +7       ; to LABORATORY TEST (#60) file tests

 +8       ;

EP        ; EP

PEP       ; PEP

 +1        NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)

 +2       ;

 +3        DO SETBLRVS

 +4       ;

 +5        DO ADDTMENU^BLRGMENU("MAPTESTS^BLRMPRL2","Map Reference Lab Tests")

 +6        DO ADDTMENU^BLRGMENU("MAPRPT^BLRMPRL2","Mapped Tests Report")

 +7        DO ADDTMENU^BLRGMENU("UMAPRPT^BLRMPRL2","Non-Mapped Tests Report")

 +8       ;

 +9        DO MENUDRVR^BLRGMENU("RPMS Lab","Reference Lab Mapping")

 +10       QUIT

 +11      ;

MAPTESTS  ; EP - main routine driver

 +1        NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)

 +2       ;

 +3        DO SETBLRVS("MAPTESTS")

 +4        SET HEADER(1)="BLR Reference Lab File (#9009026)"

 +5        SET HEADER(2)="Mapping File 9009026 Tests to File 60 Tests"

 +6       ;

 +7        FOR

               IF $$ASK(.BLRRL)="Q"

                   QUIT

               Begin DoDot:1

 +8                SET MAPPED=0

 +9                KILL HEADER(3)

 +10               SET HEADER(3)=$$CJ^XLFSTR("Reference Lab: "_$$GET1^DIQ(9009026,BLRRL,.01),IOM)

 +11               DO ORR(BLRRL)

 +12               IF MAPPED

                       Begin DoDot:2

 +13                       DO HEADERDT^BLRGMENU

 +14                       WRITE !!,?4,MAPPED," 9009026 Test",$SELECT(MAPPED=1:"",1:"s")," Mapped."

 +15                       DO PRESSKEY^BLRGMENU(9)

                       End DoDot:2

 +16               KILL HEADER(3)

               End DoDot:1

 +17      ;

 +18       QUIT

 +19      ;

 +20      ;

ASK(BLRRL) ;-- Ask which Reference Lab to map

 +1        DO HEADERDT^BLRGMENU

 +2       ;

 +3       ; Get the Reference Labs in the BLR REFERENCE LAB file and create DIR array

 +4        DO ^XBFMK

 +5        SET TAB=$JUSTIFY("",5)

           SET TAB2=TAB_TAB

 +6        SET DIR("L")=""

 +7        SET DIR("L",1)=TAB_"Reference Labs in BLR REFERENCE LAB (#9009026) File:"

 +8        SET DIR("L",2)=""

 +9        SET LINE=2

 +10       SET RLD0=.9999999

           SET CNT=0

           SET SELSTR="SO^"

 +11       FOR

               SET RLD0=$ORDER(^BLRRL(RLD0))

               IF RLD0<1

                   QUIT

               Begin DoDot:1

 +12               SET CNT=CNT+1

 +13               SET RLIEN(CNT)=RLD0

 +14               SET REFLABN=$$GET1^DIQ(9009026,RLD0,.01)

 +15               SET SELSTR=SELSTR_CNT_":"_$PIECE(REFLABN," ")_";"

 +16               SET LINE=LINE+1

 +17               SET DIR("L",LINE)=TAB2_$JUSTIFY(CNT,2)_")  "_REFLABN

               End DoDot:1

 +18      ;

 +19      ; Remove trailing semi-colon

           SET SELSTR=$EXTRACT(SELSTR,1,$LENGTH(SELSTR)-1)

 +20      ;

 +21       SET DIR("A")=TAB_"Select Reference Lab"

 +22       SET DIR(0)=SELSTR

 +23       DO ^DIR

 +24      ;

 +25       IF +$GET(DIRUT)!(+$GET(Y)<1)

               QUIT "Q"

 +26      ;

 +27       SET BLRRL=RLIEN(Y)

 +28       QUIT "OK"

 +29      ;

ORR(RL)   ; EP - ask and map Reference Lab test(s)

 +1        SET ONGO="YES"

 +2        FOR

               IF ONGO="NO"

                   QUIT

               Begin DoDot:1

 +3                DO HEADERDT^BLRGMENU

 +4                DO ^XBFMK

 +5                KILL BLROR

 +6                SET DIC="^BLRRL("_BLRRL_",1,"

                   SET DA(1)=RL

                   SET DIC(0)="AELMQZ"

 +7                SET DIC("A")="Select Reference Lab (#9009026) File's Test to Map: "

 +8                DO ^DIC

 +9                IF Y<0

                       SET ONGO="NO"

                       QUIT

 +10      ;

 +11               WRITE !

 +12      ;

 +13               SET BLROR=+Y

 +14      ; S DIE=DIC,DA=BLROR,DR=".01:10"  ;added edit of .01 at DKR request 2/3/2006 3/24/2006 added field 10

 +15      ; Do NOT allow editing of .01 field

                   SET DIE=DIC

                   SET DA=BLROR

                   SET DR=".02:10"

 +16               DO ^DIE

 +17               SET MAPPED=MAPPED+1

               End DoDot:1

 +18       QUIT

 +19      ;

 +20      ;

MAPRPT    ; EP - Mapped Tests' Report

 +1        NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)

 +2       ;

 +3        IF $$MAPRPTI()="Q"

               QUIT

 +4       ;

 +5        FOR

               SET TESTNAME=$ORDER(^BLRRL(BLRRL,1,"B",TESTNAME))

               IF TESTNAME=""!(QFLG="Q")

                   QUIT

               Begin DoDot:1

 +6                SET RLD1=0

 +7                FOR

                       SET RLD1=$ORDER(^BLRRL(BLRRL,1,"B",TESTNAME,RLD1))

                       IF RLD1<1!(QFLG="Q")

                           QUIT

                       DO MAPRPTL

               End DoDot:1

 +8       ;

 +9        WRITE !!,?4,CNT," Tests",!!

 +10       DO ^%ZISC

 +11      ;

 +12       DO PRESSKEY^BLRGMENU(9)

 +13       QUIT

 +14      ;

MAPRPTI() ; EP - Initialization

 +1        DO SETBLRVS("MAPRPT")

 +2        SET HEADER(1)="BLR Reference Lab File (#9009026)"

 +3       ;

 +4        IF $$ASK(.BLRRL)="Q"

               QUIT "Q"

 +5       ;

 +6        DO HEADERDT^BLRGMENU

 +7        DO HEADONE^BLRGMENU(.HDRONE)

 +8       ;

 +9        SET HEADER(2)="Reference Lab: "_$$GET1^DIQ(9009026,BLRRL,.01)

 +10       SET HEADER(3)=$$CJ^XLFSTR("Mapped Tests",IOM)

 +11       DO HEADERDT^BLRGMENU

 +12      ;

 +13       DO ^%ZIS

 +14       IF POP

               QUIT $$BADSTUFQ^BLRUTIL7("Quit or Invalid Device Entered.")

 +15       USE IO

 +16      ;

 +17       SET HEADER(4)=" "

 +18       SET HEADER(5)=$$COLHEAD^BLRGMENU("File 9009026",22)

 +19       SET $EXTRACT(HEADER(5),25)=$$COLHEAD^BLRGMENU("File 60",32)

 +20       SET $EXTRACT(HEADER(5),60)="Order"

 +21       SET $EXTRACT(HEADER(5),70)="Result"

 +22       SET HEADER(6)="Test Name"

 +23       SET $EXTRACT(HEADER(6),25)="IEN"

 +24       SET $EXTRACT(HEADER(6),35)="Description"

 +25       SET $EXTRACT(HEADER(6),60)="Code"

 +26       SET $EXTRACT(HEADER(6),70)="Code"

 +27      ;

 +28       SET MAXLINES=IOSL-4

           SET LINES=MAXLINES+10

 +29       SET (CNT,PG)=0

 +30       SET QFLG="NO"

 +31      ;

 +32       SET TESTNAME=""

 +33       QUIT "OK"

 +34      ;

MAPRPTL   ; EP - Line of Data

 +1        IF $$MAPRPTB()="Q"

               QUIT

 +2       ;

 +3        IF LINES>MAXLINES

               DO HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)

               IF QFLG="Q"

                   QUIT

 +4       ;

 +5        WRITE $EXTRACT(TESTNAME,1,22)

 +6        WRITE ?24,F60IEN

 +7        WRITE ?34,F60DESC

 +8        WRITE ?59,ORDCODE

 +9        WRITE ?69,RESULTC

 +10       WRITE !

 +11       SET LINES=LINES+1

 +12       SET CNT=CNT+1

 +13       QUIT

 +14      ;

MAPRPTB() ; EP - Break out data

 +1        SET RLD1IEN=RLD1_","_BLRRL

 +2        SET F60IEN=$$GET1^DIQ(9009026.01,RLD1IEN,.02,"I")

 +3        IF +F60IEN<1

               QUIT "Q"

 +4       ;

 +5        SET F60DESC=$EXTRACT($$GET1^DIQ(9009026.01,RLD1IEN,.02),1,22)

 +6       ;

 +7        SET ORDCODE=$$GET1^DIQ(9009026.01,RLD1IEN,.03)

 +8        SET RESULTC=$$GET1^DIQ(9009026.01,RLD1IEN,.04)

 +9        QUIT "OK"

 +10      ;

UMAPRPT   ; EP - Un-Mapped Tests' Report

 +1        NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)

 +2       ;

 +3        IF $$UMAPRPTI()="Q"

               QUIT

 +4       ;

 +5        FOR

               SET TESTNAME=$ORDER(^BLRRL(BLRRL,1,"B",TESTNAME))

               IF TESTNAME=""!(QFLG="Q")

                   QUIT

               Begin DoDot:1

 +6                SET RLD1=0

 +7                FOR

                       SET RLD1=$ORDER(^BLRRL(BLRRL,1,"B",TESTNAME,RLD1))

                       IF RLD1<1!(QFLG="Q")

                           QUIT

                       DO UMAPRPTL

               End DoDot:1

 +8       ;

 +9        WRITE !!,?4,CNT," Tests",!!

 +10       DO ^%ZISC

 +11      ;

 +12       DO PRESSKEY^BLRGMENU(9)

 +13       QUIT

 +14      ;

UMAPRPTI() ; EP - Initialization

 +1        DO SETBLRVS("UMAPRPT")

 +2        SET HEADER(1)="BLR Reference Lab File (#9009026)"

 +3       ;

 +4        IF $$ASK(.BLRRL)="Q"

               QUIT "Q"

 +5       ;

 +6        DO HEADERDT^BLRGMENU

 +7        DO HEADONE^BLRGMENU(.HDRONE)

 +8       ;

 +9        SET HEADER(2)="Reference Lab: "_$$GET1^DIQ(9009026,BLRRL,.01)

 +10       SET HEADER(3)=$$CJ^XLFSTR("Non-Mapped Tests",IOM)

 +11       DO HEADERDT^BLRGMENU

 +12      ;

 +13       DO ^%ZIS

 +14       IF POP

               QUIT $$BADSTUFQ^BLRUTIL7("Quit or Invalid Device Entered.")

 +15       USE IO

 +16      ;

 +17       SET HEADER(4)=" "

 +18       SET $EXTRACT(HEADER(5),60)="Order"

 +19       SET $EXTRACT(HEADER(5),70)="Result"

 +20       SET HEADER(6)="File 9009026 Test Name"

 +21       SET $EXTRACT(HEADER(6),60)="Code"

 +22       SET $EXTRACT(HEADER(6),70)="Code"

 +23      ;

 +24       SET MAXLINES=IOSL-4

           SET LINES=MAXLINES+10

 +25       SET (CNT,PG)=0

 +26       SET QFLG="NO"

 +27      ;

 +28       SET TESTNAME=""

 +29       QUIT "OK"

 +30      ;

UMAPRPTL  ; EP - Line of Data

 +1        IF $$UMAPRPTB()="Q"

               QUIT

 +2       ;

 +3        IF LINES>MAXLINES

               DO HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)

               IF QFLG="Q"

                   QUIT

 +4       ;

 +5        WRITE $SELECT($LENGTH($TRANSLATE(TESTNAME," ")):$EXTRACT(TESTNAME,1,22),1:"<"_RLD1_">")

 +6        WRITE ?59,ORDCODE

 +7        WRITE ?69,RESULTC

 +8        WRITE !

 +9        SET LINES=LINES+1

 +10       SET CNT=CNT+1

 +11       QUIT

 +12      ;

UMAPRPTB() ; EP - Break out data

 +1        SET RLD1IEN=RLD1_","_BLRRL

 +2        IF +$$GET1^DIQ(9009026.01,RLD1IEN,.02,"I")

               QUIT "Q"

 +3       ;

 +4        SET ORDCODE=$$GET1^DIQ(9009026.01,RLD1IEN,.03)

 +5        SET RESULTC=$$GET1^DIQ(9009026.01,RLD1IEN,.04)

 +6        QUIT "OK"

 +7       ;

 +8       ;

 +9       ; ============================= UTILITIES =============================

 +10      ;

JUSTNEW   ; EP - Generic RPMS EXCLUSIVE NEW

 +1        NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)

 +2       ;

 +3        QUIT

 +4       ;

SETBLRVS(TWO) ; EP - Set the BLRVERN variable(s)

 +1        KILL BLRVERN,BLRVERN2

 +2       ;

 +3        SET BLRVERN=$PIECE($PIECE($TEXT(+1),";")," ")

 +4        IF $LENGTH($GET(TWO))

               SET BLRVERN2=$GET(TWO)

 +5        QUIT

 +6       ;

TESTASK   ; EP - Test the ASK function

 +1        NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)

 +2       ;

 +3        DO SETBLRVS

 +4        SET HEADER(1)="BLR Reference Lab (#9009026)"

 +5        SET HEADER(2)="Mapping File 9009026 Tests to File 60 Tests"

 +6       ;

 +7        IF $$ASK(.BLRRL)="Q"

               QUIT

 +8       ;

 +9        WRITE !!,?4,"BLRRL:",BLRRL,!

 +10       WRITE ?9,$$GET1^DIQ(9009026,BLRRL,.01),!!

 +11      ;

 +12       QUIT

 +13      ;

TFIELDS   ; EP - Test asking fields

 +1        NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)

 +2       ;

 +3        DO ^XBFMK

 +4        SET DIR(0)="PO^60:EMZ"

 +5        DO ^DIR

 +6        IF +$GET(DIRUT)!(+Y<1)

               QUIT

 +7       ;

 +8        KILL FDA,ERRS

 +9        SET FDA(9009026.01,"1,1,",.02)=+Y

 +10       DO UPDATE^DIE("S","FDA",,"ERRS")

 +11      ;

 +12       DO ^XBFMK

 +13      ; Use Quest as the Ref Lab

 +14       SET (BLRRL,BLROR,RL)=1

 +15       SET DIC="^BLRRL("_BLRRL_",1,"

           SET DA(1)=RL

           SET DIC(0)="AELMQZ"

 +16      ; Do NOT allow editing of .01 field

           SET DIE=DIC

           SET DA=BLROR

           SET DR=".03:10"

 +17       DO ^DIE

 +18       SET MAPPED=MAPPED+1

 +19       QUIT

BLRMPRL2.m