BLRLLPRR.m

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

 ;

SETMENU ; EP -- Lab Programmer Menu

 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       ;

SETMENU   ; EP -- Lab Programmer Menu

 +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