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
Q
;
; 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")
Q
;
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)
;
Q
;
;
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
Q
;
;
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)
Q
;
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
Q
;
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)
Q
;
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
Q
;
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)
;
Q
;
SETBLRVS(TWO) ; EP - Set the BLRVERN variable(s)
K BLRVERN,BLRVERN2
;
S BLRVERN=$P($P($T(+1),";")," ")
S:$L($G(TWO)) BLRVERN2=$G(TWO)
Q
;
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),!!
;
Q
;
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
Q
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
