BLRLLPRR ; IHS/MSC/MKK - Lab Label Printer Reset Routine ; [ February 29, 2012 8:00 AM ]
;;5.2;LAB SERVICE;**1031**;NOV 01, 1997
;
EEP ; EP
D EEP^BLRGMENU
Q
;
EP ; EP
PEP ; EP
NEW BLRMMENU,BLRVERN,LINES
;
D SETMENU
;
; Main Menu driver
D MENUDRFM^BLRGMENU("RPMS Lab Module","Reset Lab Label Printing")
Q
;
S BLRVERN=$P($P($T(+1),";")," ")
;
D ADDTMENU^BLRGMENU("GETNEWR^BLRLLPRR","Overwrite LRLABEL4 With Specified Routine")
D ADDTMENU^BLRGMENU("GETNEWO^BLRLLPRR","Replace ROUTINE in Specified Option")
D ADDTMENU^BLRGMENU("PAIRS^BLRLLPRR","List Print Routines")
Q
;
GETNEWR ; EP
NEW CODE,ERRS,NEWRTN,PRINTRTN
NEW HD1,HEADER,LINES,MAXLINES,PG,QFLG
;
I $$GETPRINI(.NEWRTN)="Q" D Q
. W !,?4,"Routine not selected.",!
. D PRESSKEY^BLRGMENU(9)
;
Q:$$REALLY("LRLABEL4")="Q"
;
; Retrieve code from new routine and store in CODE array
S GETIT=$$ROUTINE^%R(NEWRTN_".INT",.CODE,.ERRS,"L")
I GETIT<1 D DOERRS(.ERRS) Q
;
; Backup & then Compile & then save new version of LRLABEL4 routine
S GETIT=$$ROUTINE^%R("LRLABEL4.INT",.CODE,.ERRS,"BCS")
I GETIT<1 D DOERRS(.ERRS) Q
;
W !!,?4,"LRLABEL4 routine has been successfully over-written by ",NEWRTN,".",!
D PRESSKEY^BLRGMENU(9)
;
Q
;
GETPRINI(NEWRTN) ; EP - GET new Print Routine - INItialization of variables
S HEADER(1)="IHS Lab Label Printer Utilities"
S HEADER(2)="Print Routine Replacement"
;
Q:$$USERTNS(.NEWRTN)="Q" "Q"
;
Q "OK"
;
USERTNS(NEWRTN) ; EP
NEW DASH,HOWMANY,LABELRTN,ORD,RTNS,STR
;
D PRNTRTNS(.LABELRTN,.HOWMANY)
;
D SETUPDIR("Print Routines",.LABELRTN,10,20,"Routine",HOWMANY)
;
D HEADERDT^BLRGMENU
D ^DIR
;
S (X,NEWRTN)=$O(LABELRTN(+$G(Y),""))
Q $S($L(X)>0:X,1:"Q")
;
SETUPDIR(PROMPT,ARRAY,TABONE,TABTWO,HEADER1,HOWMANY) ; EP - SETUP DIR array and variables
NEW DASH,HOWLONG,ORD,SELSTR,WHAT
;
S DASH=$TR($J("",IOM)," ","-")
S HOWLONG=IOM-TABTWO
;
D ^XBFMK
S DIR("A")="Enter Response (1-"_HOWMANY_")"
S ORD=0,CNT=5
F S ORD=$O(ARRAY(ORD)) Q:ORD="" D
. S WHAT=$O(ARRAY(ORD,""))
. K STR
. S $E(STR,5)=$J(ORD,2)
. S $E(STR,TABONE)=WHAT
. S:HOWLONG>5 $E(STR,TABTWO)=$E($G(ARRAY(ORD,WHAT)),1,HOWLONG)
. S DIR("L",CNT)=STR
. S CNT=CNT+1
. I ORD>1 S SELSTR=SELSTR_";"_ORD_":"
. I ORD<2 S SELSTR="SO^"_ORD_":"
S DIR("L",1)="Select one of the "_PROMPT_" below:"
S DIR("L",2)=""
K STR
S $E(STR,TABONE)=HEADER1
S $E(STR,TABTWO)="Description"
S DIR("L",3)=STR
K STR
S $E(STR,TABONE)=$E(DASH,1,(TABTWO-TABONE)-2)
S $E(STR,TABTWO)=$E(DASH,1,HOWLONG)
S DIR("L",4)=STR
S DIR("L")=""
S DIR(0)=SELSTR
Q
;
REALLY(WOT) ; EP - Prompt for certainty -- Ask 3 Times.
NEW ANSWER
;
S ANSWER=$$AREUSURE("CERTAIN",,WOT)
Q:ANSWER="Q" "Q"
;
S ANSWER=$$AREUSURE("REALLY certain",,WOT)
Q:ANSWER="Q" "Q"
;
Q $$AREUSURE("ABSOLUTELY certain","LAST CHANCE",WOT)
Q:ANSWER="Q" "Q"
;
Q "OK"
;
AREUSURE(MSG,WARNING,WOT) ; EP
NEW MIDPOINT,WARNLEN
;
D HEADERDT^BLRGMENU
;
I $D(WARNING) D
. S WARNING=$TR(WARNING," ","@")
. S WARNING=$$CJ^XLFSTR(">>>>>>>>>>>@"_WARNING_"@<<<<<<<<<<<",IOM)
. S WARNING=$TR(WARNING,"@"," ")
. W WARNING
. W !
;
NEW PROMPT,TAB
D ^XBFMK
S PROMPT=$J("",5)_"Are you "_MSG_" you want to overwrite "_WOT
I $L(PROMPT)<71 S DIR("A")=PROMPT
I $L(PROMPT)>70 K DIR("A") D
. S DIR("A",1)=$J("",5)_"Are you "_MSG_" you want to"
. S DIR("A",2)=" "
. S DIR("A")=$J("",5)_"overwrite "_WOT
S DIR(0)="YO"
S DIR("B")="NO"
D ^DIR
;
I $E($$UP^XLFSTR(X),1)'="Y" D Q "Q"
. S XPDABORT=1
. S TAB=9
. S PROMPT="YES was NOT entered. Overwriting of "_WOT_" Aborted."
. S:($L(PROMPT)+9)>70 TAB=4
. W !!,?TAB,"YES was NOT entered. Overwriting of "_WOT_" Aborted.",!
. D PRESSKEY^BLRGMENU(9)
;
Q "OK"
;
GETNEWO ; EP
NEW CNT,CODE,ERRS,INITRTN,LABELRTN,NEWRTN,OPTSIEN,PRINTRTN,WOTOPTS
NEW HD1,HEADER,LINES,MAXLINES,PG,QFLG
;
I $$GETOOINI(.WOTOPTS,.OPTSIEN)="Q" D Q
. W !,?4,"Option not selected.",!
. D PRESSKEY^BLRGMENU(9)
;
K HEADER(3)
S HEADER(3)=$$CJ^XLFSTR("Option "_WOTOPTS_" Selected",IOM)
;
I $$GETORINI(.INITRTN)="Q" D Q
. W !,?4,"Routine not selected.",!
. D PRESSKEY^BLRGMENU(9)
;
Q:$$REALLY("the Initialization Routine")="Q"
;
D SETOPTIR(WOTOPTS,OPTSIEN,INITRTN)
Q
;
SETOPTIR(WOTOPTS,OPTSIEN,INITRTN) ; EP -- Resets ROUTINE in selected option
NEW ERRS,NEWRTN
;
D ^XBFMK
S DA=OPTSIEN
S DIE=19
S DR="25///"_INITRTN
D ^DIE
;
D ^XBFMK
S NEWRTN=$$GET1^DIQ(19,OPTSIEN,25,,,"ERRS")
I $D(ERRS) D Q
. W !,?4,"Errors Occurred.",!
. D PRESSKEY^BLRGMENU(9)
;
D HEADERDT^BLRGMENU
W !,?4,"For Option ",WOTOPTS,!!
W ?9,"ROUTINE:",NEWRTN
D PRESSKEY^BLRGMENU(14)
;
Q
;
GETOOINI(WOTOPTS,OPTSIEN) ; EP - GET Option & Option's IEN
S HEADER(1)="IHS Lab Label Printer Utilities"
S HEADER(2)="Option Routine Replacement"
S HEADER(3)=$$CJ^XLFSTR("Option Selection",IOM)
;
Q:$$USEORTNS(.WOTOPTS)="Q" "Q"
D GOPTIEN(WOTOPTS,.OPTSIEN)
Q "OK"
;
GETORINI(INITRTN) ; EP - GET Initialization Routine
K HEADER(4)
S HEADER(4)=$$CJ^XLFSTR("Routine Selection",IOM)
S CNT=0
;
D INITRTNS(.LABELRTN,.CNT)
;
D SETUPDIR("Initialization Routines",.LABELRTN,10,20,"Routine",CNT)
;
D HEADERDT^BLRGMENU
D ^DIR
;
S (X,INITRTN)=$O(LABELRTN(+$G(Y),""))
Q $S($L(X)>0:X,1:"Q")
;
USEORTNS(WOTOPTS) ; EP
NEW DASH,HOWMANY,LABELRTN,ORD,RTNS,STR,WOTOPTSA
;
S DASH=$TR($J("",IOM)," ","-")
D GETOPTS(.WOTOPTSA,.HOWMANY)
;
D SETUPDIR("Options",.WOTOPTSA,10,41,"Option",HOWMANY)
;
D HEADERDT^BLRGMENU
D ^DIR
;
S (X,WOTOPTS)=$O(WOTOPTSA(+$G(Y),""))
Q $S($L(X)>0:X,1:"Q")
;
GOPTIEN(OPT,IEN) ; EP - Get Option's IEN from File 19
D ^XBFMK
S X=OPT,DIC="19"
D ^DIC
S IEN=+$G(Y)
Q
;
GETOPTS(WOTOPTS,CNT) ; EP -- Set WOTOPTS array with BLR startup Options
NEW OPT,ZERO
S OPT=.9999999
F S OPT=$O(^DIC(19,OPT)) Q:OPT<1 D
. S ZERO=$G(^DIC(19,OPT,0))
. Q:ZERO'["BLR"
. Q:ZERO'["STARTUP"
. S CNT=1+$G(CNT)
. S WOTOPTS(CNT,$P(ZERO,"^"))=$P(ZERO,"^",2)
Q
;
DOERRS(ERRORS) ; EP
W !!,"Errors follow:",!!
W $$FMTERR^%R(.ERRORS)
W !
D PRESSKEY^BLRGMENU(4)
Q
;
PRNTRTNS(LABELRTN,CNT) ; EP -- Set LABELRTN array with Lab Label Print Routines on the system
NEW RTNS,SEED,STR
;
F SEED="BLRLAB","BLRIPL" D
. S RTNS=SEED
. F S RTNS=$O(^ROUTINE(RTNS)) Q:RTNS=""!($E(RTNS,1,6)'=SEED) D
.. Q:SEED="BLRIPL"&($E($RE(RTNS),1)="I") ; "I" routines are initializers
.. S CNT=1+$G(CNT)
.. D STRRTNS(.LABELRTN,RTNS,CNT)
;
Q
;
STRRTNS(LABELRTN,RTNS,CNT) ; EP -- Store routine & description
S STR=$$TRIM^XLFSTR($P($G(^ROUTINE(RTNS,0,1)),";",2),"LR"," ")
S STR=$$TRIM^XLFSTR($P(STR,"-",2,99),"LR"," ")
S STR=$$TRIM^XLFSTR($P(STR,"["),"LR"," ")
S LABELRTN(CNT,RTNS)=STR
Q
;
INITRTNS(LABELRTN,CNT) ; EP -- Set LABELRTN array with Lab Label Initialization Routines on the system
NEW RTNS,SEED,STR
;
F SEED="BLRBAR","BLRIPL" D
. S RTNS=SEED
. F S RTNS=$O(^ROUTINE(RTNS)) Q:RTNS=""!($E(RTNS,1,6)'=SEED) D
.. Q:SEED="BLRIPL"&($E($RE(RTNS),1)="P") ; "P" routines are the print routines
.. S CNT=1+$G(CNT)
.. D STRRTNS(.LABELRTN,RTNS,CNT)
;
Q
;
; DEAD CODE follows, for the time being
GETPRTN(NEWRTN) ; EP -- Get Print Routine's Name
NEW NAME
;
S NAME=""
F Q:$L(NAME)!(NAME="Q") D
. D HEADERDT^BLRGMENU
. D ^XBFMK
. S DIR(0)="FAO"
. S DIR("A")="Select Lab Label Print Routine: "
. D ^DIR
. I $L($G(X))<1 D Q:NAME="Q"
.. W !,?4,"Invalid/No Entry.",!!
.. D ^XBFMK
.. S DIR(0)="YAO"
.. S DIR("A")=" Quit?"
.. S DIR("B")="YES"
.. D ^DIR
.. I +$G(Y)>0 D
... S NAME="Q"
... W !,?4,"Routine Ends.",!
. ;
. I $D(^ROUTINE($G(X)))<1 D Q
.. W !,?4,"Routine ",$G(X)," Does Not Exist in this UCI.",!
. ;
. S NAME=$G(X)
;
I $L(NAME)<1 Q "Q"
;
S NEWRTN=NAME
Q "OK"
;
PAIRS ; EP - List all the routines that are tied to Lab Label Printing.
NEW CODE,ERRS,NEWRTN,PRINTRTN
NEW BLRVERN,CNT,HD1,HEADER,LINES,MAXLINES,PG,QFLG
NEW RTNS,SEED,STR
;
D PAIRINIT
;
F SEED="BLRBAR","BLRLAB","BLRIPL" D
. S RTNS=SEED
. F S RTNS=$O(^ROUTINE(RTNS)) Q:RTNS=""!($E(RTNS,1,6)'=SEED) D
.. D PAIRLINE
;
W !,?19,"COUNT:",CNT
D ^%ZISC
;
D PRESSKEY^BLRGMENU(9)
Q
;
PAIRINIT ; EP - Initialize variables
S BLRVERN=$P($P($T(+1),";")," ")
;
S HEADER(1)="IHS Lab Label Printer Utilities"
S HEADER(2)="Print Routines Report"
S HEADER(3)=$$CJ^XLFSTR("All BLRBAR, BLRLAB and BLRIPL Lab Label Routines",IOM)
;
D HEADERDT^BLRGMENU
D ^%ZIS
I POP D Q "Q"
. W !,?4,"Device Not Available. Routine Ends.",!!
. D PRESSKEY^BLRGMENU(9)
U IO
;
I IOST["C-VT" D HEADONE2^BLRLUAC2(.HD1) W !
;
S MAXLINES=IOSL-4
S LINES=MAXLINES+10
;
S (CNT,PG)=0,QFLG="NO"
;
S HEADER(4)=" "
S HEADER(5)="Routine"
S $E(HEADER(5),15)="Routine Description"
;
Q
;
PAIRLINE ; EP - Print a line of data
I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HD1) Q:QFLG="Q"
;
S STR=$$TRIM^XLFSTR($P($P($G(^ROUTINE(RTNS,0,1)),";",2),"-",2),"LR"," ")
W $E(RTNS,1,13)
W ?14,$E(STR,1,65)
W !
S LINES=LINES+1
S CNT=1+$G(CNT)
Q
BLRLLPRR ; IHS/MSC/MKK - Lab Label Printer Reset Routine ; [ February 29, 2012 8:00 AM ]
+1 ;;5.2;LAB SERVICE;**1031**;NOV 01, 1997
+2 ;
EEP ; EP
+1 DO EEP^BLRGMENU
+2 QUIT
+3 ;
EP ; EP
PEP ; EP
+1 NEW BLRMMENU,BLRVERN,LINES
+2 ;
+3 DO SETMENU
+4 ;
+5 ; Main Menu driver
+6 DO MENUDRFM^BLRGMENU("RPMS Lab Module","Reset Lab Label Printing")
+7 QUIT
+8 ;
+1 SET BLRVERN=$PIECE($PIECE($TEXT(+1),";")," ")
+2 ;
+3 DO ADDTMENU^BLRGMENU("GETNEWR^BLRLLPRR","Overwrite LRLABEL4 With Specified Routine")
+4 DO ADDTMENU^BLRGMENU("GETNEWO^BLRLLPRR","Replace ROUTINE in Specified Option")
+5 DO ADDTMENU^BLRGMENU("PAIRS^BLRLLPRR","List Print Routines")
+6 QUIT
+7 ;
GETNEWR ; EP
+1 NEW CODE,ERRS,NEWRTN,PRINTRTN
+2 NEW HD1,HEADER,LINES,MAXLINES,PG,QFLG
+3 ;
+4 IF $$GETPRINI(.NEWRTN)="Q"
Begin DoDot:1
+5 WRITE !,?4,"Routine not selected.",!
+6 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT
+7 ;
+8 IF $$REALLY("LRLABEL4")="Q"
QUIT
+9 ;
+10 ; Retrieve code from new routine and store in CODE array
+11 SET GETIT=$$ROUTINE^%R(NEWRTN_".INT",.CODE,.ERRS,"L")
+12 IF GETIT<1
DO DOERRS(.ERRS)
QUIT
+13 ;
+14 ; Backup & then Compile & then save new version of LRLABEL4 routine
+15 SET GETIT=$$ROUTINE^%R("LRLABEL4.INT",.CODE,.ERRS,"BCS")
+16 IF GETIT<1
DO DOERRS(.ERRS)
QUIT
+17 ;
+18 WRITE !!,?4,"LRLABEL4 routine has been successfully over-written by ",NEWRTN,".",!
+19 DO PRESSKEY^BLRGMENU(9)
+20 ;
+21 QUIT
+22 ;
GETPRINI(NEWRTN) ; EP - GET new Print Routine - INItialization of variables
+1 SET HEADER(1)="IHS Lab Label Printer Utilities"
+2 SET HEADER(2)="Print Routine Replacement"
+3 ;
+4 IF $$USERTNS(.NEWRTN)="Q"
QUIT "Q"
+5 ;
+6 QUIT "OK"
+7 ;
USERTNS(NEWRTN) ; EP
+1 NEW DASH,HOWMANY,LABELRTN,ORD,RTNS,STR
+2 ;
+3 DO PRNTRTNS(.LABELRTN,.HOWMANY)
+4 ;
+5 DO SETUPDIR("Print Routines",.LABELRTN,10,20,"Routine",HOWMANY)
+6 ;
+7 DO HEADERDT^BLRGMENU
+8 DO ^DIR
+9 ;
+10 SET (X,NEWRTN)=$ORDER(LABELRTN(+$GET(Y),""))
+11 QUIT $SELECT($LENGTH(X)>0:X,1:"Q")
+12 ;
SETUPDIR(PROMPT,ARRAY,TABONE,TABTWO,HEADER1,HOWMANY) ; EP - SETUP DIR array and variables
+1 NEW DASH,HOWLONG,ORD,SELSTR,WHAT
+2 ;
+3 SET DASH=$TRANSLATE($JUSTIFY("",IOM)," ","-")
+4 SET HOWLONG=IOM-TABTWO
+5 ;
+6 DO ^XBFMK
+7 SET DIR("A")="Enter Response (1-"_HOWMANY_")"
+8 SET ORD=0
SET CNT=5
+9 FOR
SET ORD=$ORDER(ARRAY(ORD))
IF ORD=""
QUIT
Begin DoDot:1
+10 SET WHAT=$ORDER(ARRAY(ORD,""))
+11 KILL STR
+12 SET $EXTRACT(STR,5)=$JUSTIFY(ORD,2)
+13 SET $EXTRACT(STR,TABONE)=WHAT
+14 IF HOWLONG>5
SET $EXTRACT(STR,TABTWO)=$EXTRACT($GET(ARRAY(ORD,WHAT)),1,HOWLONG)
+15 SET DIR("L",CNT)=STR
+16 SET CNT=CNT+1
+17 IF ORD>1
SET SELSTR=SELSTR_";"_ORD_":"
+18 IF ORD<2
SET SELSTR="SO^"_ORD_":"
End DoDot:1
+19 SET DIR("L",1)="Select one of the "_PROMPT_" below:"
+20 SET DIR("L",2)=""
+21 KILL STR
+22 SET $EXTRACT(STR,TABONE)=HEADER1
+23 SET $EXTRACT(STR,TABTWO)="Description"
+24 SET DIR("L",3)=STR
+25 KILL STR
+26 SET $EXTRACT(STR,TABONE)=$EXTRACT(DASH,1,(TABTWO-TABONE)-2)
+27 SET $EXTRACT(STR,TABTWO)=$EXTRACT(DASH,1,HOWLONG)
+28 SET DIR("L",4)=STR
+29 SET DIR("L")=""
+30 SET DIR(0)=SELSTR
+31 QUIT
+32 ;
REALLY(WOT) ; EP - Prompt for certainty -- Ask 3 Times.
+1 NEW ANSWER
+2 ;
+3 SET ANSWER=$$AREUSURE("CERTAIN",,WOT)
+4 IF ANSWER="Q"
QUIT "Q"
+5 ;
+6 SET ANSWER=$$AREUSURE("REALLY certain",,WOT)
+7 IF ANSWER="Q"
QUIT "Q"
+8 ;
+9 QUIT $$AREUSURE("ABSOLUTELY certain","LAST CHANCE",WOT)
+10 IF ANSWER="Q"
QUIT "Q"
+11 ;
+12 QUIT "OK"
+13 ;
AREUSURE(MSG,WARNING,WOT) ; EP
+1 NEW MIDPOINT,WARNLEN
+2 ;
+3 DO HEADERDT^BLRGMENU
+4 ;
+5 IF $DATA(WARNING)
Begin DoDot:1
+6 SET WARNING=$TRANSLATE(WARNING," ","@")
+7 SET WARNING=$$CJ^XLFSTR(">>>>>>>>>>>@"_WARNING_"@<<<<<<<<<<<",IOM)
+8 SET WARNING=$TRANSLATE(WARNING,"@"," ")
+9 WRITE WARNING
+10 WRITE !
End DoDot:1
+11 ;
+12 NEW PROMPT,TAB
+13 DO ^XBFMK
+14 SET PROMPT=$JUSTIFY("",5)_"Are you "_MSG_" you want to overwrite "_WOT
+15 IF $LENGTH(PROMPT)<71
SET DIR("A")=PROMPT
+16 IF $LENGTH(PROMPT)>70
KILL DIR("A")
Begin DoDot:1
+17 SET DIR("A",1)=$JUSTIFY("",5)_"Are you "_MSG_" you want to"
+18 SET DIR("A",2)=" "
+19 SET DIR("A")=$JUSTIFY("",5)_"overwrite "_WOT
End DoDot:1
+20 SET DIR(0)="YO"
+21 SET DIR("B")="NO"
+22 DO ^DIR
+23 ;
+24 IF $EXTRACT($$UP^XLFSTR(X),1)'="Y"
Begin DoDot:1
+25 SET XPDABORT=1
+26 SET TAB=9
+27 SET PROMPT="YES was NOT entered. Overwriting of "_WOT_" Aborted."
+28 IF ($LENGTH(PROMPT)+9)>70
SET TAB=4
+29 WRITE !!,?TAB,"YES was NOT entered. Overwriting of "_WOT_" Aborted.",!
+30 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT "Q"
+31 ;
+32 QUIT "OK"
+33 ;
GETNEWO ; EP
+1 NEW CNT,CODE,ERRS,INITRTN,LABELRTN,NEWRTN,OPTSIEN,PRINTRTN,WOTOPTS
+2 NEW HD1,HEADER,LINES,MAXLINES,PG,QFLG
+3 ;
+4 IF $$GETOOINI(.WOTOPTS,.OPTSIEN)="Q"
Begin DoDot:1
+5 WRITE !,?4,"Option not selected.",!
+6 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT
+7 ;
+8 KILL HEADER(3)
+9 SET HEADER(3)=$$CJ^XLFSTR("Option "_WOTOPTS_" Selected",IOM)
+10 ;
+11 IF $$GETORINI(.INITRTN)="Q"
Begin DoDot:1
+12 WRITE !,?4,"Routine not selected.",!
+13 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT
+14 ;
+15 IF $$REALLY("the Initialization Routine")="Q"
QUIT
+16 ;
+17 DO SETOPTIR(WOTOPTS,OPTSIEN,INITRTN)
+18 QUIT
+19 ;
SETOPTIR(WOTOPTS,OPTSIEN,INITRTN) ; EP -- Resets ROUTINE in selected option
+1 NEW ERRS,NEWRTN
+2 ;
+3 DO ^XBFMK
+4 SET DA=OPTSIEN
+5 SET DIE=19
+6 SET DR="25///"_INITRTN
+7 DO ^DIE
+8 ;
+9 DO ^XBFMK
+10 SET NEWRTN=$$GET1^DIQ(19,OPTSIEN,25,,,"ERRS")
+11 IF $DATA(ERRS)
Begin DoDot:1
+12 WRITE !,?4,"Errors Occurred.",!
+13 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT
+14 ;
+15 DO HEADERDT^BLRGMENU
+16 WRITE !,?4,"For Option ",WOTOPTS,!!
+17 WRITE ?9,"ROUTINE:",NEWRTN
+18 DO PRESSKEY^BLRGMENU(14)
+19 ;
+20 QUIT
+21 ;
GETOOINI(WOTOPTS,OPTSIEN) ; EP - GET Option & Option's IEN
+1 SET HEADER(1)="IHS Lab Label Printer Utilities"
+2 SET HEADER(2)="Option Routine Replacement"
+3 SET HEADER(3)=$$CJ^XLFSTR("Option Selection",IOM)
+4 ;
+5 IF $$USEORTNS(.WOTOPTS)="Q"
QUIT "Q"
+6 DO GOPTIEN(WOTOPTS,.OPTSIEN)
+7 QUIT "OK"
+8 ;
GETORINI(INITRTN) ; EP - GET Initialization Routine
+1 KILL HEADER(4)
+2 SET HEADER(4)=$$CJ^XLFSTR("Routine Selection",IOM)
+3 SET CNT=0
+4 ;
+5 DO INITRTNS(.LABELRTN,.CNT)
+6 ;
+7 DO SETUPDIR("Initialization Routines",.LABELRTN,10,20,"Routine",CNT)
+8 ;
+9 DO HEADERDT^BLRGMENU
+10 DO ^DIR
+11 ;
+12 SET (X,INITRTN)=$ORDER(LABELRTN(+$GET(Y),""))
+13 QUIT $SELECT($LENGTH(X)>0:X,1:"Q")
+14 ;
USEORTNS(WOTOPTS) ; EP
+1 NEW DASH,HOWMANY,LABELRTN,ORD,RTNS,STR,WOTOPTSA
+2 ;
+3 SET DASH=$TRANSLATE($JUSTIFY("",IOM)," ","-")
+4 DO GETOPTS(.WOTOPTSA,.HOWMANY)
+5 ;
+6 DO SETUPDIR("Options",.WOTOPTSA,10,41,"Option",HOWMANY)
+7 ;
+8 DO HEADERDT^BLRGMENU
+9 DO ^DIR
+10 ;
+11 SET (X,WOTOPTS)=$ORDER(WOTOPTSA(+$GET(Y),""))
+12 QUIT $SELECT($LENGTH(X)>0:X,1:"Q")
+13 ;
GOPTIEN(OPT,IEN) ; EP - Get Option's IEN from File 19
+1 DO ^XBFMK
+2 SET X=OPT
SET DIC="19"
+3 DO ^DIC
+4 SET IEN=+$GET(Y)
+5 QUIT
+6 ;
GETOPTS(WOTOPTS,CNT) ; EP -- Set WOTOPTS array with BLR startup Options
+1 NEW OPT,ZERO
+2 SET OPT=.9999999
+3 FOR
SET OPT=$ORDER(^DIC(19,OPT))
IF OPT<1
QUIT
Begin DoDot:1
+4 SET ZERO=$GET(^DIC(19,OPT,0))
+5 IF ZERO'["BLR"
QUIT
+6 IF ZERO'["STARTUP"
QUIT
+7 SET CNT=1+$GET(CNT)
+8 SET WOTOPTS(CNT,$PIECE(ZERO,"^"))=$PIECE(ZERO,"^",2)
End DoDot:1
+9 QUIT
+10 ;
DOERRS(ERRORS) ; EP
+1 WRITE !!,"Errors follow:",!!
+2 WRITE $$FMTERR^%R(.ERRORS)
+3 WRITE !
+4 DO PRESSKEY^BLRGMENU(4)
+5 QUIT
+6 ;
PRNTRTNS(LABELRTN,CNT) ; EP -- Set LABELRTN array with Lab Label Print Routines on the system
+1 NEW RTNS,SEED,STR
+2 ;
+3 FOR SEED="BLRLAB","BLRIPL"
Begin DoDot:1
+4 SET RTNS=SEED
+5 FOR
SET RTNS=$ORDER(^ROUTINE(RTNS))
IF RTNS=""!($EXTRACT(RTNS,1,6)'=SEED)
QUIT
Begin DoDot:2
+6 ; "I" routines are initializers
IF SEED="BLRIPL"&($EXTRACT($REVERSE(RTNS),1)="I")
QUIT
+7 SET CNT=1+$GET(CNT)
+8 DO STRRTNS(.LABELRTN,RTNS,CNT)
End DoDot:2
End DoDot:1
+9 ;
+10 QUIT
+11 ;
STRRTNS(LABELRTN,RTNS,CNT) ; EP -- Store routine & description
+1 SET STR=$$TRIM^XLFSTR($PIECE($GET(^ROUTINE(RTNS,0,1)),";",2),"LR"," ")
+2 SET STR=$$TRIM^XLFSTR($PIECE(STR,"-",2,99),"LR"," ")
+3 SET STR=$$TRIM^XLFSTR($PIECE(STR,"["),"LR"," ")
+4 SET LABELRTN(CNT,RTNS)=STR
+5 QUIT
+6 ;
INITRTNS(LABELRTN,CNT) ; EP -- Set LABELRTN array with Lab Label Initialization Routines on the system
+1 NEW RTNS,SEED,STR
+2 ;
+3 FOR SEED="BLRBAR","BLRIPL"
Begin DoDot:1
+4 SET RTNS=SEED
+5 FOR
SET RTNS=$ORDER(^ROUTINE(RTNS))
IF RTNS=""!($EXTRACT(RTNS,1,6)'=SEED)
QUIT
Begin DoDot:2
+6 ; "P" routines are the print routines
IF SEED="BLRIPL"&($EXTRACT($REVERSE(RTNS),1)="P")
QUIT
+7 SET CNT=1+$GET(CNT)
+8 DO STRRTNS(.LABELRTN,RTNS,CNT)
End DoDot:2
End DoDot:1
+9 ;
+10 QUIT
+11 ;
+12 ; DEAD CODE follows, for the time being
GETPRTN(NEWRTN) ; EP -- Get Print Routine's Name
+1 NEW NAME
+2 ;
+3 SET NAME=""
+4 FOR
IF $LENGTH(NAME)!(NAME="Q")
QUIT
Begin DoDot:1
+5 DO HEADERDT^BLRGMENU
+6 DO ^XBFMK
+7 SET DIR(0)="FAO"
+8 SET DIR("A")="Select Lab Label Print Routine: "
+9 DO ^DIR
+10 IF $LENGTH($GET(X))<1
Begin DoDot:2
+11 WRITE !,?4,"Invalid/No Entry.",!!
+12 DO ^XBFMK
+13 SET DIR(0)="YAO"
+14 SET DIR("A")=" Quit?"
+15 SET DIR("B")="YES"
+16 DO ^DIR
+17 IF +$GET(Y)>0
Begin DoDot:3
+18 SET NAME="Q"
+19 WRITE !,?4,"Routine Ends.",!
End DoDot:3
End DoDot:2
IF NAME="Q"
QUIT
+20 ;
+21 IF $DATA(^ROUTINE($GET(X)))<1
Begin DoDot:2
+22 WRITE !,?4,"Routine ",$GET(X)," Does Not Exist in this UCI.",!
End DoDot:2
QUIT
+23 ;
+24 SET NAME=$GET(X)
End DoDot:1
+25 ;
+26 IF $LENGTH(NAME)<1
QUIT "Q"
+27 ;
+28 SET NEWRTN=NAME
+29 QUIT "OK"
+30 ;
PAIRS ; EP - List all the routines that are tied to Lab Label Printing.
+1 NEW CODE,ERRS,NEWRTN,PRINTRTN
+2 NEW BLRVERN,CNT,HD1,HEADER,LINES,MAXLINES,PG,QFLG
+3 NEW RTNS,SEED,STR
+4 ;
+5 DO PAIRINIT
+6 ;
+7 FOR SEED="BLRBAR","BLRLAB","BLRIPL"
Begin DoDot:1
+8 SET RTNS=SEED
+9 FOR
SET RTNS=$ORDER(^ROUTINE(RTNS))
IF RTNS=""!($EXTRACT(RTNS,1,6)'=SEED)
QUIT
Begin DoDot:2
+10 DO PAIRLINE
End DoDot:2
End DoDot:1
+11 ;
+12 WRITE !,?19,"COUNT:",CNT
+13 DO ^%ZISC
+14 ;
+15 DO PRESSKEY^BLRGMENU(9)
+16 QUIT
+17 ;
PAIRINIT ; EP - Initialize variables
+1 SET BLRVERN=$PIECE($PIECE($TEXT(+1),";")," ")
+2 ;
+3 SET HEADER(1)="IHS Lab Label Printer Utilities"
+4 SET HEADER(2)="Print Routines Report"
+5 SET HEADER(3)=$$CJ^XLFSTR("All BLRBAR, BLRLAB and BLRIPL Lab Label Routines",IOM)
+6 ;
+7 DO HEADERDT^BLRGMENU
+8 DO ^%ZIS
+9 IF POP
Begin DoDot:1
+10 WRITE !,?4,"Device Not Available. Routine Ends.",!!
+11 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT "Q"
+12 USE IO
+13 ;
+14 IF IOST["C-VT"
DO HEADONE2^BLRLUAC2(.HD1)
WRITE !
+15 ;
+16 SET MAXLINES=IOSL-4
+17 SET LINES=MAXLINES+10
+18 ;
+19 SET (CNT,PG)=0
SET QFLG="NO"
+20 ;
+21 SET HEADER(4)=" "
+22 SET HEADER(5)="Routine"
+23 SET $EXTRACT(HEADER(5),15)="Routine Description"
+24 ;
+25 QUIT
+26 ;
PAIRLINE ; EP - Print a line of data
+1 IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,HD1)
IF QFLG="Q"
QUIT
+2 ;
+3 SET STR=$$TRIM^XLFSTR($PIECE($PIECE($GET(^ROUTINE(RTNS,0,1)),";",2),"-",2),"LR"," ")
+4 WRITE $EXTRACT(RTNS,1,13)
+5 WRITE ?14,$EXTRACT(STR,1,65)
+6 WRITE !
+7 SET LINES=LINES+1
+8 SET CNT=1+$GET(CNT)
+9 QUIT
