Routine: BLRGMENU

BLRGMENU ; IHS/OIT/MKK - GENERIC MENU DRIVER ; 17-Oct-2014 09:22 ; MKK

 ;;5.2;IHS LABORATORY;**1022,1033,1034**;NOV 01, 1997;Build 88

;;

 ;; The main array is the BLRMMENU array.  It's format is

 ;;      BLRMMENU(CNT,RTN,MENUDISP)

 ;;           where      CNT = # of Item

 ;;                      RTN = Full routine name, including Entry Points

 ;;                 MENUDISP = Menu display string

;;

 ;; The BLRMMENU array is added to by using ADDTMENU.

;;

 ;; The calling routines must ensure that BLRMMENU is intialized before

 ;; using the ADDTMENU call.

;;

EEP ; Ersatz EP

 D ^XBCLS

 W !!!,$C(7),$C(7),$C(7)

 W !!

 W $$SHOUTMSG("USE LABEL")

 W !!

 W !,$C(7),$C(7),$C(7),!

 ; Display up to 4 Header lines

MENUDRVR(HD1,HD2,HD3,HD4)              ; EP

 I $G(HD1)="" Q                        ; Must be at least 1 HEADER line

 I $G(IOM)="" D HOME^%ZIS              ; Reset screen variables, if need be

 NEW HEADER,HDCNT,MMSEL,MAX            ; NEW variables so they don't hang around.

 F  D  Q:MMSEL'>0                      ; "Infinite loop"

 . D MAINHEAD                          ; Set up MAIN header array

. ;

 . S:HDCNT<3 HEADER(HDCNT)="MAIN MENU"

 . S:HDCNT>2 HEADER(HDCNT)=$$CJ^XLFSTR("MAIN MENU",IOM)

. ;

 . D BLRGSHSH                          ; Generic Header

 . D DISPMENU                          ; Display the BLRMMENU array

 . D GOFORIT                           ; Select & Do menu item

 Q                                     ; Exit

 ; Display up to 4 Header lines in FileMan format

MENUDRFM(HD1,HD2,HD3,HD4)         ; EP

 I $G(HD1)="" Q                   ; Must be at least 1 HEADER line

 I $G(IOM)="" D HOME^%ZIS

 NEW HEADER,HDCNT,MMSEL,MAX,STR,STR2

 F  D  Q:MMSEL'>0                 ; "Infinite loop"

 . D MAINHEAD

 . D BLRGSHSH

 . D DISPMEFM                     ; Display BLRMMENU array in FileMan format

 . D GOFORIT

 Q                                ; Exit

 ; Set up Main Menu driver heading

MAINHEAD ;                       ; EP

 K HEADER

 S HEADER(1)=HD1

 S HDCNT=2

 S:$G(HD2)'="" HEADER(2)=HD2,HDCNT=HDCNT+1

 S:$G(HD3)'="" HEADER(3)=HD3,HDCNT=HDCNT+1

 S:$G(HD4)'="" HEADER(4)=HD4,HDCNT=HDCNT+1

 S MAX=$G(BLRMMENU(-1))           ; Maximum # of menu items

 ; Select Item and try to do it

GOFORIT                           ; EP

 NEW STR,STR2

 S MMSEL=$$SELITEM                ; Select the Item from the menu

 I MMSEL<1 Q                      ; If zero, just RETURN

W !

 S STR=$P($G(BLRMMENU(MMSEL)),"|",1)   ; Get routine "string"

 I STR="" Q                            ; If routine = Null, just RETURN

 ; If routine string is of the form LABEL^ROUTINE, then have to make

 ; sure to test the existance of the ROUTINE and not the LABEL^ROUTINE.

 ; This is the reason for the code involving the STR2 variable.

 S STR2=$P($P(STR,"^",2),"(",1)

 I STR2="" Q                           ; If no routine Name, skip

 Q:$L($T(@STR))<1  ; IHS/MSC/MKK - LR*5.2*1033 - If Line Label doesn't exist, skip

 I $$EXIST^%R(STR2_".INT") D @STR      ; If routine exists, do it

 ; Select Item Function

SELITEM()                         ; EP

 D ^XBFMK                         ; Kernel call cleans up FILEMAN vars

 S DIR("A")="Select"

 S DIR(0)="NO^1:"_MAX

 S DIR("T")=30                    ; IHS/MSC/MKK - LR*5.2*1033

 D ^DIR

 Q +$G(Y)

 ; Add Menu Items to BLRMMENU array

 ;      RTN = Routine

 ;      DISPSTR = Display String

ADDTMENU(RTN,DISPSTR)             ; EP

 I $G(RTN)="" Q

 I $G(DISPSTR)="" Q

 NEW MAX

 S MAX=1+$O(BLRMMENU(""),-1)

 S BLRMMENU(MAX)=RTN_"|"_DISPSTR

 S BLRMMENU(-1)=MAX               ; Special node

 ; Display BLRMMENU array -- Tab positions are hardcoded

DISPMENU                          ; EP

 NEW ITEM

 NEW CNT,TAB                      ; IHS/MSC/MKK - LR*5.2*1033

 S ITEM=0

 S CNT=1,TAB(1)=3,TAB(2)=42       ; IHS/MSC/MKK - LR*5.2*1033

 ; F  S ITEM=$O(BLRMMENU(ITEM))  Q:ITEM=""  D

 ; . I ITEM#2'=0 D

 ; .. W ?4,$J(ITEM,2),") "

 ; .. W $E($P($G(BLRMMENU(ITEM)),"|",2),1,31)

 ; . I ITEM#2=0 D

 ; .. W ?41,$J(ITEM,2),") "

 ; .. W $E($P($G(BLRMMENU(ITEM)),"|",2),1,31)

 ; .. W !

 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033

 F  S ITEM=$O(BLRMMENU(ITEM))  Q:ITEM=""  D

 . W ?TAB(CNT),$J(ITEM,2),") "

 . W $E($P($G(BLRMMENU(ITEM)),"|",2),1,33)

 . S CNT=CNT+1

 . I CNT>2 W !  S CNT=1

 . ; ----- END IHS/MSC/MKK - LR*5.2*1033

W !

 ; Display BLRMMENU array in FileMan format

DISPMEFM                          ; EP

 NEW ITEM

 S ITEM=0

 F  S ITEM=$O(BLRMMENU(ITEM))  Q:ITEM=""  D

 . W ?4,ITEM

 . ; W ?9,$E($P($G(BLRMMENU(ITEM)),"|",2),1,53)

 . W ?9,$E($P($G(BLRMMENU(ITEM)),"|",2),1,70)    ; IHS/MSC/MKK - LR*5.2*1033

 . W !

W !

 ; New Page with just Header & Date & Time

HEADERDT                               ; EP

BLRGSHSH                               ; EP

 NEW J,TMPLN                           ; Temporary Line

 NEW RMPSOS                            ; RPMS' Operating System

 NEW TIMELEN,TIMESTR

 I IOST["C-VT" D ^XBCLS                ; Clear sceen and home cursor

 I IOST'["C-VT" W @IOF                 ; Form Feed if not terminal

 W $$CJ^XLFSTR($$LOC^XBFUNC,IOM),!     ; Location

 S TMPLN=$$CJ^XLFSTR(HEADER(1),IOM)              ; Center string

 S $E(TMPLN,1,13)="Date:"_$$HTE^XLFDT($H,"2DZ")  ; Today's Date

 S $E(TMPLN,IOM-15)=$J("Time:"_$$NOWTIME,16)     ; Current Time

 S TMPLN=$$TRIM^XLFSTR(TMPLN,"R"," ")            ; Trim extra spaces

 W TMPLN,!

 I $G(HEADER(2))'="" D

 . S TMPLN=$$CJ^XLFSTR(HEADER(2),IOM)

 . S:$G(BLRVERN)'="" $E(TMPLN,(IOM-10))=$J(BLRVERN,11)     ; Version number

 . S TMPLN=$$TRIM^XLFSTR(TMPLN,"R"," ")

 . ; If BLRVERN2 variable exists, put it in HEADER array, if room

 . I $L($G(BLRVERN2)),$TR($E(TMPLN,1,$L(BLRVERN2)+2)," ")="" S $E(TMPLN,1,$L(BLRVERN2))=BLRVERN2    ; IHS/MSC/MKK - LR*5.2*1033

 . W TMPLN,!

 ; Other Header lines, iff they exist

 F J=3:1  Q:$G(HEADER(J))=""  D

 . W $G(HEADER(J)),!

 W $TR($J("",IOM)," ","-"),!           ; Dashed Line

 S LINES=J+2                           ; Re-intialize # lines

 ; Header with Date/Time & Page Numbers

BLRGHWPN(PG,QFLG,HEADONE)         ; EP

 D HEDPGNUM

 ; HEaDer with PaGe Number & date/time

HEADERPG(PG,QFLG,HEADONE)         ; EP

 D HEDPGNUM

 ; HEaDer with PaGe NUMber & date & time

HEDPGNUM ;                       ; EP

 NEW J,TMPLN

 NEW TIMELEN,TIMESTR

 ; Check "Print Header Once" Flag

 I $E($G(HEADONE),1,1)="Y"&(PG>0) S QFLG="HO"  Q

 I IOST["C-VT"&(PG>0) D  I $G(QFLG)="Q" Q   ; If Fileman quit, then skip

 . D ^XBFMK

 . W !

 . S DIR(0)="E",(X,Y)=""

 . S DIR("T")=30                       ; IHS/OIT/MKK - LR*5.2*1032

 . D ^DIR

 . I $G(X)="^" S QFLG="Q"

 I IOST["C-VT" D ^XBCLS                ; If terminal, clear sceen & home cursor

 I IOST'["C-VT" W @IOF                 ; Form Feed if not terminal

 W $$CJ^XLFSTR($$LOC^XBFUNC,IOM),!     ; Location

 S PG=PG+1                             ; Increment Page Number

 S TMPLN=$$CJ^XLFSTR(HEADER(1),IOM)    ; Center Header string

 S $E(TMPLN,1,13)="Date:"_$$NOWDATE    ; Today's Date

 S $E(TMPLN,IOM-10)=$J("Page "_PG,11)  ; Page Number

 S TMPLN=$$TRIM^XLFSTR(TMPLN,"R"," ")  ; Trim extra spaces

 W TMPLN,!

 S TMPLN=$$CJ^XLFSTR(HEADER(2),IOM)

 S TIMESTR="Time:"_$$NOWTIME                            ; Current Time

 S TIMELEN=$L(TIMESTR)                                  ; Length of string

 S $E(TMPLN,1,TIMELEN)=TIMESTR

 S:$G(BLRVERN)'="" $E(TMPLN,(IOM-10))=$J(BLRVERN,11)    ; Version number

 S TMPLN=$$TRIM^XLFSTR(TMPLN,"R"," ")

 W TMPLN,!

 ; F J=3:1  Q:$G(HEADER(J))=""  D

 ; . W $G(HEADER(J)),!

 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1032

 ; If BLRVERN2 variable exists, put it in HEADER array, if room

 I $G(HEADER(3))'="" D

 . S TMPLN=HEADER(3)

 . I $G(BLRVERN2)'="",$TR($E(TMPLN,1,$L(BLRVERN2)+1)," ")="" S $E(TMPLN,1,$L(BLRVERN2))=BLRVERN2    ; Label

 . S TMPLN=$$TRIM^XLFSTR(TMPLN,"R"," ")

 . W TMPLN,!

 ; Other Header lines, iff they exist

 F J=4:1  Q:$G(HEADER(J))=""  D

 . W $G(HEADER(J)),!

 ; ----- END IHS/OIT/MKK - LR*5.2*1032

 W $TR($J("",IOM)," ","-"),!           ; Dashed line

 S LINES=J+2

 ; Generic "Press Any Key"

BLRGPGR(TAB)                           ; EP

 NEW TABSTR

 I $G(TAB)'="" S TABSTR=$J("",TAB)_"Press RETURN Key"

 I $G(TAB)="" S TABSTR="Press RETURN Key"

 W !                         ; Blank line

 D ^XBFMK

 S DIR(0)="E",(X,Y)=""

 S DIR("A")=TABSTR

 D ^DIR

 I $G(X)="^" S QFLG="Q"      ; If Fileman quit, then set Quit Flag

 ; Generic "Press Any Key"

PRESSKEY(TAB)                          ; EP

 NEW TABSTR

 S TABSTR=$J("",+$G(TAB))_"Press RETURN Key"

 W !                         ; Blank line

 D ^XBFMK

 S DIR(0)="E",(X,Y)=""

 S DIR("A")=TABSTR

 D ^DIR

 I $G(X)="^" S QFLG="Q"      ; If Fileman quit, then set Quit Flag

 ; NOW DATE in MM/DD/YY format

NOWDATE()                              ; EP

 Q $$HTE^XLFDT($H,"2DZ")

 ; NOW TIME in xx:xx AM/PM format

NOWTIME()                              ; EP

 Q $$UP^XLFSTR($P($$HTE^XLFDT($H,"2MPZ")," ",2,3))

 ; Return a string like >>>> STR <<<<

SHOUTMSG(STR,RM)                       ; EP

 NEW HALFLEN,J,STRLEN,TMPSTR

 I $G(RM)="" S RM=IOM

 S HALFLEN=(RM\2)-(($L(STR)+2)\2)

 S TMPSTR=$TR($J("",HALFLEN)," ",">")

 S TMPSTR=TMPSTR_" "_STR_" "

 S STRLEN=$L(TMPSTR)

 F J=STRLEN:1:(RM-1) S TMPSTR=TMPSTR_"<"

 Q TMPSTR

HEADONE(HD1) ; EP -- Asks if user wants only 1 header line

 D ^XBFMK

 S DIR("A")="One Header Line ONLY"

 S DIR("B")="NO"

 S DIR(0)="YO"

 D ^DIR

 S HD1=$S(+$G(Y)=1:"YES",1:"NO")

 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033

 ;       TAB = Beginning Column

 ;       STR = String to display

 ;       MAX = # of characters

LINEWRAP(TAB,STR,MAX) ; EP - If line too long, wrap it.

 Q:$L($G(STR))<1

 NEW LINE,LM,ONGO,SPACE,STR1,STR2,WRAPSTR

 S WRAPSTR="",NEEDSP=0

 S STR=$$TRIM^XLFSTR(STR,"LR"," ")  ; Get rid of leading & trailing blanks

 ; Determine if the length of any space-delmited piece of the string > MAX

 F SPACE=1:1:$L(STR," ") S:$L($P(STR," ",SPACE))>MAX NEEDSP=NEEDSP+1

 ; If $L(STR)> MAX and has no spaces, or the $L of any space-delimited

 ; piece of STR > MAX, then setup spaces every MAX characters so that

 ; the ^DIWP routine will "wrap" STR so that no piece's $L is > MAX.

 I NEEDSP!((STR'[$C(32)&($L(STR)>MAX))) D

 . S ONGO=STR

 . F  Q:$L(ONGO)<MAX  D

 .. S STR1=$E(ONGO,1,MAX)

 .. S STR2=$E(ONGO,(MAX+1),(MAX*2))

 .. S WRAPSTR=WRAPSTR_STR1_" "_STR2

 .. S ONGO=$E(ONGO,((MAX*2)+1),$L(ONGO))

 .. S:$L(ONGO) WRAPSTR=WRAPSTR_" "

 . S:$L(ONGO) WRAPSTR=WRAPSTR_ONGO

 ; If WRAPSTR exists, trim trailing spaces

 S:$L(WRAPSTR) WRAPSTR=$$TRIM^XLFSTR(WRAPSTR,"R"," ")

 S X=$S($L(WRAPSTR):WRAPSTR,1:STR)

 ; Use FileMan DIWP routine to "wrap" string, if necessary.

 K ^UTILITY($J,"W")

 S LM=2

 S DIWL=LM,DIWR="",DIWF="C"_MAX

 D ^DIWP

 ; Use loop to output result without extra line feed

 S LINE=0

 F  S LINE=$O(^UTILITY($J,"W",LM,LINE))  Q:LINE<1  D

 . W:LINE=1 ?TAB

 . I LINE>1 W !,?TAB  S LINES=1+$G(LINES)

 . W $$TRIM^XLFSTR($G(^UTILITY($J,"W",LM,LINE,0)),"L",$C(9))

 K ^UTILITY($J,"W")

DASH(LEN) ; EP - Dashed Characters

 W $TR($J("",LEN)," ","-")

 Q ""

BUILDHED(STR,NOCENTER) ; EP - Build the HEADER array

 NEW CURLINE

 S NOCENTER=$G(NOCENTER,1)

 S CURLINE=+$O(HEADER("A"),-1)+1

 I CURLINE<3!(NOCENTER) S HEADER(CURLINE)=STR  Q

 S HEADER(CURLINE)=$$CJ^XLFSTR(STR,IOM)

 ; ----- END IHS/MSC/MKK - LR*5.2*1033

 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034

SHOWBOX(MSG,LM,RM) ; EP - Display Message in a "box"

 NEW CRTLINE,J,MAXIT,AROUND

 S RM=$G(RM,IOM)

 S LM=$G(LM,0)

 S RM=RM-LM

 S MAXIT="@"

 F J=1:1:$L(MSG) S MAXIT=MAXIT_$E(MSG,J,J)_"@"

 S AROUND=$TR($J("",8+$L(MAXIT))," ","@")

 S MAXIT="@@!!"_$TR(MAXIT," ","@")_"!!@@"

 W !!

 F J=1,2 W ?LM,$TR($J("",RM)," ","*"),!

 W ?LM,$TR($$CJ^XLFSTR(AROUND,RM)," @","* "),!

 W ?LM,$TR($$CJ^XLFSTR(MAXIT,RM)," @","* "),!

 W ?LM,$TR($$CJ^XLFSTR(AROUND,RM)," @","* "),!

 F J=1,2 W ?LM,$TR($J("",RM)," ","*"),!

COLHEAD(MSG,WIDTH,DASHER) ; EP - COLumn HEADer String

 NEW COLSTR

 S DASHER=$G(DASHER,"=")

 S COLSTR="@"_$TR(MSG," ","@")_"@"

 Q $TR($$CJ^XLFSTR(COLSTR,WIDTH)," @",DASHER_" ")

 ; ----- END IHS/MSC/MKK - LR*5.2*1034

BLRGMENU  ; IHS/OIT/MKK - GENERIC MENU DRIVER ; 17-Oct-2014 09:22 ; MKK

 +1       ;;5.2;IHS LABORATORY;**1022,1033,1034**;NOV 01, 1997;Build 88

 +2       ;;

 +3       ;; The main array is the BLRMMENU array.  It's format is

 +4       ;;      BLRMMENU(CNT,RTN,MENUDISP)

 +5       ;;           where      CNT = # of Item

 +6       ;;                      RTN = Full routine name, including Entry Points

 +7       ;;                 MENUDISP = Menu display string

 +8       ;;

 +9       ;; The BLRMMENU array is added to by using ADDTMENU.

 +10      ;;

 +11      ;; The calling routines must ensure that BLRMMENU is intialized before

 +12      ;; using the ADDTMENU call.

 +13      ;;

EEP       ; Ersatz EP

 +1        DO ^XBCLS

 +2        WRITE !!!,$CHAR(7),$CHAR(7),$CHAR(7)

 +3        WRITE !!

 +4        WRITE $$SHOUTMSG("USE LABEL")

 +5        WRITE !!

 +6        WRITE !,$CHAR(7),$CHAR(7),$CHAR(7),!

 +7        QUIT

 +8       ;

 +9       ; Display up to 4 Header lines

MENUDRVR(HD1,HD2,HD3,HD4) ; EP

 +1       ; Must be at least 1 HEADER line

           IF $GET(HD1)=""

               QUIT

 +2       ;

 +3       ; Reset screen variables, if need be

           IF $GET(IOM)=""

               DO HOME^%ZIS

 +4       ;

 +5       ; NEW variables so they don't hang around.

           NEW HEADER,HDCNT,MMSEL,MAX

 +6       ;

 +7       ; "Infinite loop"

FOR

               Begin DoDot:1

 +8       ; Set up MAIN header array

                   DO MAINHEAD

 +9       ;

 +10               IF HDCNT<3

                       SET HEADER(HDCNT)="MAIN MENU"

 +11               IF HDCNT>2

                       SET HEADER(HDCNT)=$$CJ^XLFSTR("MAIN MENU",IOM)

 +12      ;

 +13      ; Generic Header

                   DO BLRGSHSH

 +14      ; Display the BLRMMENU array

                   DO DISPMENU

 +15      ; Select & Do menu item

                   DO GOFORIT

               End DoDot:1

               IF MMSEL'>0

                   QUIT

 +16      ;

 +17      ; Exit

           QUIT

 +18      ;

 +19      ; Display up to 4 Header lines in FileMan format

MENUDRFM(HD1,HD2,HD3,HD4) ; EP

 +1       ; Must be at least 1 HEADER line

           IF $GET(HD1)=""

               QUIT

 +2       ;

 +3        IF $GET(IOM)=""

               DO HOME^%ZIS

 +4        NEW HEADER,HDCNT,MMSEL,MAX,STR,STR2

 +5       ;

 +6       ; "Infinite loop"

FOR

               Begin DoDot:1

 +7                DO MAINHEAD

 +8                DO BLRGSHSH

 +9       ; Display BLRMMENU array in FileMan format

                   DO DISPMEFM

 +10               DO GOFORIT

               End DoDot:1

               IF MMSEL'>0

                   QUIT

 +11      ;

 +12      ; Exit

           QUIT

 +13      ;

 +14      ; Set up Main Menu driver heading

MAINHEAD  ;                       ; EP

 +1        KILL HEADER

 +2        SET HEADER(1)=HD1

 +3        SET HDCNT=2

 +4        IF $GET(HD2)'=""

               SET HEADER(2)=HD2

               SET HDCNT=HDCNT+1

 +5        IF $GET(HD3)'=""

               SET HEADER(3)=HD3

               SET HDCNT=HDCNT+1

 +6        IF $GET(HD4)'=""

               SET HEADER(4)=HD4

               SET HDCNT=HDCNT+1

 +7       ;

 +8       ; Maximum # of menu items

           SET MAX=$GET(BLRMMENU(-1))

 +9        QUIT

 +10      ;

 +11      ; Select Item and try to do it

GOFORIT   ; EP

 +1        NEW STR,STR2

 +2       ;

 +3       ; Select the Item from the menu

           SET MMSEL=$$SELITEM

 +4       ; If zero, just RETURN

           IF MMSEL<1

               QUIT

 +5       ;

 +6        WRITE !

 +7       ; Get routine "string"

           SET STR=$PIECE($GET(BLRMMENU(MMSEL)),"|",1)

 +8       ; If routine = Null, just RETURN

           IF STR=""

               QUIT

 +9       ;

 +10      ; If routine string is of the form LABEL^ROUTINE, then have to make

 +11      ; sure to test the existance of the ROUTINE and not the LABEL^ROUTINE.

 +12      ; This is the reason for the code involving the STR2 variable.

 +13       SET STR2=$PIECE($PIECE(STR,"^",2),"(",1)

 +14      ; If no routine Name, skip

           IF STR2=""

               QUIT

 +15      ;

 +16      ; IHS/MSC/MKK - LR*5.2*1033 - If Line Label doesn't exist, skip

           IF $LENGTH($TEXT(@STR))<1

               QUIT

 +17      ;

 +18      ; If routine exists, do it

           IF $$EXIST^%R(STR2_".INT")

               DO @STR

 +19       QUIT

 +20      ;

 +21      ; Select Item Function

SELITEM() ; EP

 +1       ; Kernel call cleans up FILEMAN vars

           DO ^XBFMK

 +2        SET DIR("A")="Select"

 +3        SET DIR(0)="NO^1:"_MAX

 +4       ; IHS/MSC/MKK - LR*5.2*1033

           SET DIR("T")=30

 +5        DO ^DIR

 +6        QUIT +$GET(Y)

 +7       ;

 +8       ; Add Menu Items to BLRMMENU array

 +9       ;      RTN = Routine

 +10      ;      DISPSTR = Display String

ADDTMENU(RTN,DISPSTR) ; EP

 +1        IF $GET(RTN)=""

               QUIT

 +2        IF $GET(DISPSTR)=""

               QUIT

 +3       ;

 +4        NEW MAX

 +5        SET MAX=1+$ORDER(BLRMMENU(""),-1)

 +6        SET BLRMMENU(MAX)=RTN_"|"_DISPSTR

 +7       ;

 +8       ; Special node

           SET BLRMMENU(-1)=MAX

 +9        QUIT

 +10      ;

 +11      ; Display BLRMMENU array -- Tab positions are hardcoded

DISPMENU  ; EP

 +1        NEW ITEM

 +2       ; IHS/MSC/MKK - LR*5.2*1033

           NEW CNT,TAB

 +3       ;

 +4        SET ITEM=0

 +5       ; IHS/MSC/MKK - LR*5.2*1033

           SET CNT=1

           SET TAB(1)=3

           SET TAB(2)=42

 +6       ; F  S ITEM=$O(BLRMMENU(ITEM))  Q:ITEM=""  D

 +7       ; . I ITEM#2'=0 D

 +8       ; .. W ?4,$J(ITEM,2),") "

 +9       ; .. W $E($P($G(BLRMMENU(ITEM)),"|",2),1,31)

 +10      ; . I ITEM#2=0 D

 +11      ; .. W ?41,$J(ITEM,2),") "

 +12      ; .. W $E($P($G(BLRMMENU(ITEM)),"|",2),1,31)

 +13      ; .. W !

 +14      ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033

 +15       FOR

               SET ITEM=$ORDER(BLRMMENU(ITEM))

               IF ITEM=""

                   QUIT

               Begin DoDot:1

 +16               WRITE ?TAB(CNT),$JUSTIFY(ITEM,2),") "

 +17               WRITE $EXTRACT($PIECE($GET(BLRMMENU(ITEM)),"|",2),1,33)

 +18               SET CNT=CNT+1

 +19               IF CNT>2

                       WRITE !

                       SET CNT=1

 +20      ; ----- END IHS/MSC/MKK - LR*5.2*1033

               End DoDot:1

 +21       WRITE !

 +22       QUIT

 +23      ;

 +24      ; Display BLRMMENU array in FileMan format

DISPMEFM  ; EP

 +1        NEW ITEM

 +2       ;

 +3        SET ITEM=0

 +4        FOR

               SET ITEM=$ORDER(BLRMMENU(ITEM))

               IF ITEM=""

                   QUIT

               Begin DoDot:1

 +5                WRITE ?4,ITEM

 +6       ; W ?9,$E($P($G(BLRMMENU(ITEM)),"|",2),1,53)

 +7       ; IHS/MSC/MKK - LR*5.2*1033

                   WRITE ?9,$EXTRACT($PIECE($GET(BLRMMENU(ITEM)),"|",2),1,70)

 +8                WRITE !

               End DoDot:1

 +9        WRITE !

 +10       QUIT

 +11      ;

 +12      ; New Page with just Header & Date & Time

HEADERDT  ; EP

BLRGSHSH  ; EP

 +1       ; Temporary Line

           NEW J,TMPLN

 +2       ; RPMS' Operating System

           NEW RMPSOS

 +3        NEW TIMELEN,TIMESTR

 +4       ;

 +5       ; Clear sceen and home cursor

           IF IOST["C-VT"

               DO ^XBCLS

 +6       ; Form Feed if not terminal

           IF IOST'["C-VT"

               WRITE @IOF

 +7       ;

 +8       ; Location

           WRITE $$CJ^XLFSTR($$LOC^XBFUNC,IOM),!

 +9       ;

 +10      ; Center string

           SET TMPLN=$$CJ^XLFSTR(HEADER(1),IOM)

 +11      ; Today's Date

           SET $EXTRACT(TMPLN,1,13)="Date:"_$$HTE^XLFDT($HOROLOG,"2DZ")

 +12      ; Current Time

           SET $EXTRACT(TMPLN,IOM-15)=$JUSTIFY("Time:"_$$NOWTIME,16)

 +13      ; Trim extra spaces

           SET TMPLN=$$TRIM^XLFSTR(TMPLN,"R"," ")

 +14       WRITE TMPLN,!

 +15      ;

 +16       IF $GET(HEADER(2))'=""

               Begin DoDot:1

 +17               SET TMPLN=$$CJ^XLFSTR(HEADER(2),IOM)

 +18      ; Version number

                   IF $GET(BLRVERN)'=""

                       SET $EXTRACT(TMPLN,(IOM-10))=$JUSTIFY(BLRVERN,11)

 +19               SET TMPLN=$$TRIM^XLFSTR(TMPLN,"R"," ")

 +20      ; If BLRVERN2 variable exists, put it in HEADER array, if room

 +21      ; IHS/MSC/MKK - LR*5.2*1033

                   IF $LENGTH($GET(BLRVERN2))

                       IF $TRANSLATE($EXTRACT(TMPLN,1,$LENGTH(BLRVERN2)+2)," ")=""

                           SET $EXTRACT(TMPLN,1,$LENGTH(BLRVERN2))=BLRVERN2

 +22               WRITE TMPLN,!

               End DoDot:1

 +23      ;

 +24      ; Other Header lines, iff they exist

 +25       FOR J=3:1

               IF $GET(HEADER(J))=""

                   QUIT

               Begin DoDot:1

 +26               WRITE $GET(HEADER(J)),!

               End DoDot:1

 +27      ;

 +28      ; Dashed Line

           WRITE $TRANSLATE($JUSTIFY("",IOM)," ","-"),!

 +29      ;

 +30      ; Re-intialize # lines

           SET LINES=J+2

 +31      ;

 +32       QUIT

 +33      ;

 +34      ; Header with Date/Time & Page Numbers

BLRGHWPN(PG,QFLG,HEADONE) ; EP

 +1        DO HEDPGNUM

 +2        QUIT

 +3       ;

 +4       ; HEaDer with PaGe Number & date/time

HEADERPG(PG,QFLG,HEADONE) ; EP

 +1        DO HEDPGNUM

 +2        QUIT

 +3       ;

 +4       ; HEaDer with PaGe NUMber & date & time

HEDPGNUM  ;                       ; EP

 +1        NEW J,TMPLN

 +2        NEW TIMELEN,TIMESTR

 +3       ;

 +4       ; Check "Print Header Once" Flag

 +5        IF $EXTRACT($GET(HEADONE),1,1)="Y"&(PG>0)

               SET QFLG="HO"

               QUIT

 +6       ;

 +7       ; If Fileman quit, then skip

           IF IOST["C-VT"&(PG>0)

               Begin DoDot:1

 +8                DO ^XBFMK

 +9                WRITE !

 +10               SET DIR(0)="E"

                   SET (X,Y)=""

 +11      ; IHS/OIT/MKK - LR*5.2*1032

                   SET DIR("T")=30

 +12               DO ^DIR

 +13               IF $GET(X)="^"

                       SET QFLG="Q"

               End DoDot:1

               IF $GET(QFLG)="Q"

                   QUIT

 +14      ;

 +15      ; If terminal, clear sceen & home cursor

           IF IOST["C-VT"

               DO ^XBCLS

 +16      ; Form Feed if not terminal

           IF IOST'["C-VT"

               WRITE @IOF

 +17      ;

 +18      ; Location

           WRITE $$CJ^XLFSTR($$LOC^XBFUNC,IOM),!

 +19      ;

 +20      ; Increment Page Number

           SET PG=PG+1

 +21      ; Center Header string

           SET TMPLN=$$CJ^XLFSTR(HEADER(1),IOM)

 +22      ; Today's Date

           SET $EXTRACT(TMPLN,1,13)="Date:"_$$NOWDATE

 +23      ; Page Number

           SET $EXTRACT(TMPLN,IOM-10)=$JUSTIFY("Page "_PG,11)

 +24      ; Trim extra spaces

           SET TMPLN=$$TRIM^XLFSTR(TMPLN,"R"," ")

 +25       WRITE TMPLN,!

 +26      ;

 +27       SET TMPLN=$$CJ^XLFSTR(HEADER(2),IOM)

 +28      ; Current Time

           SET TIMESTR="Time:"_$$NOWTIME

 +29      ; Length of string

           SET TIMELEN=$LENGTH(TIMESTR)

 +30       SET $EXTRACT(TMPLN,1,TIMELEN)=TIMESTR

 +31      ; Version number

           IF $GET(BLRVERN)'=""

               SET $EXTRACT(TMPLN,(IOM-10))=$JUSTIFY(BLRVERN,11)

 +32       SET TMPLN=$$TRIM^XLFSTR(TMPLN,"R"," ")

 +33       WRITE TMPLN,!

 +34      ;

 +35      ; F J=3:1  Q:$G(HEADER(J))=""  D

 +36      ; . W $G(HEADER(J)),!

 +37      ;

 +38      ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1032

 +39      ; If BLRVERN2 variable exists, put it in HEADER array, if room

 +40       IF $GET(HEADER(3))'=""

               Begin DoDot:1

 +41               SET TMPLN=HEADER(3)

 +42      ; Label

                   IF $GET(BLRVERN2)'=""

                       IF $TRANSLATE($EXTRACT(TMPLN,1,$LENGTH(BLRVERN2)+1)," ")=""

                           SET $EXTRACT(TMPLN,1,$LENGTH(BLRVERN2))=BLRVERN2

 +43               SET TMPLN=$$TRIM^XLFSTR(TMPLN,"R"," ")

 +44               WRITE TMPLN,!

               End DoDot:1

 +45      ;

 +46      ; Other Header lines, iff they exist

 +47       FOR J=4:1

               IF $GET(HEADER(J))=""

                   QUIT

               Begin DoDot:1

 +48               WRITE $GET(HEADER(J)),!

               End DoDot:1

 +49      ; ----- END IHS/OIT/MKK - LR*5.2*1032

 +50      ;

 +51      ;

 +52      ; Dashed line

           WRITE $TRANSLATE($JUSTIFY("",IOM)," ","-"),!

 +53      ;

 +54       SET LINES=J+2

 +55      ;

 +56       QUIT

 +57      ;

 +58      ; Generic "Press Any Key"

BLRGPGR(TAB) ; EP

 +1        NEW TABSTR

 +2        IF $GET(TAB)'=""

               SET TABSTR=$JUSTIFY("",TAB)_"Press RETURN Key"

 +3        IF $GET(TAB)=""

               SET TABSTR="Press RETURN Key"

 +4       ;

 +5       ; Blank line

           WRITE !

 +6        DO ^XBFMK

 +7        SET DIR(0)="E"

           SET (X,Y)=""

 +8        SET DIR("A")=TABSTR

 +9        DO ^DIR

 +10      ; If Fileman quit, then set Quit Flag

           IF $GET(X)="^"

               SET QFLG="Q"

 +11      ;

 +12       QUIT

 +13      ;

 +14      ; Generic "Press Any Key"

PRESSKEY(TAB) ; EP

 +1        NEW TABSTR

 +2        SET TABSTR=$JUSTIFY("",+$GET(TAB))_"Press RETURN Key"

 +3       ; Blank line

           WRITE !

 +4        DO ^XBFMK

 +5        SET DIR(0)="E"

           SET (X,Y)=""

 +6        SET DIR("A")=TABSTR

 +7        DO ^DIR

 +8       ; If Fileman quit, then set Quit Flag

           IF $GET(X)="^"

               SET QFLG="Q"

 +9       ;

 +10       QUIT

 +11      ;

 +12      ; NOW DATE in MM/DD/YY format

NOWDATE() ; EP

 +1        QUIT $$HTE^XLFDT($HOROLOG,"2DZ")

 +2       ;

 +3       ; NOW TIME in xx:xx AM/PM format

NOWTIME() ; EP

 +1        QUIT $$UP^XLFSTR($PIECE($$HTE^XLFDT($HOROLOG,"2MPZ")," ",2,3))

 +2       ;

 +3       ; Return a string like >>>> STR <<<<

SHOUTMSG(STR,RM) ; EP

 +1        NEW HALFLEN,J,STRLEN,TMPSTR

 +2       ;

 +3        IF $GET(RM)=""

               SET RM=IOM

 +4       ;

 +5        SET HALFLEN=(RM\2)-(($LENGTH(STR)+2)\2)

 +6        SET TMPSTR=$TRANSLATE($JUSTIFY("",HALFLEN)," ",">")

 +7        SET TMPSTR=TMPSTR_" "_STR_" "

 +8        SET STRLEN=$LENGTH(TMPSTR)

 +9        FOR J=STRLEN:1:(RM-1)

               SET TMPSTR=TMPSTR_"<"

 +10       QUIT TMPSTR

 +11      ;

HEADONE(HD1) ; EP -- Asks if user wants only 1 header line

 +1        DO ^XBFMK

 +2        SET DIR("A")="One Header Line ONLY"

 +3        SET DIR("B")="NO"

 +4        SET DIR(0)="YO"

 +5        DO ^DIR

 +6        SET HD1=$SELECT(+$GET(Y)=1:"YES",1:"NO")

 +7        QUIT

 +8       ;

 +9       ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033

 +10      ;       TAB = Beginning Column

 +11      ;       STR = String to display

 +12      ;       MAX = # of characters

LINEWRAP(TAB,STR,MAX) ; EP - If line too long, wrap it.

 +1        IF $LENGTH($GET(STR))<1

               QUIT

 +2       ;

 +3        NEW LINE,LM,ONGO,SPACE,STR1,STR2,WRAPSTR

 +4       ;

 +5        SET WRAPSTR=""

           SET NEEDSP=0

 +6       ;

 +7       ; Get rid of leading & trailing blanks

           SET STR=$$TRIM^XLFSTR(STR,"LR"," ")

 +8       ;

 +9       ; Determine if the length of any space-delmited piece of the string > MAX

 +10       FOR SPACE=1:1:$LENGTH(STR," ")

               IF $LENGTH($PIECE(STR," ",SPACE))>MAX

                   SET NEEDSP=NEEDSP+1

 +11      ;

 +12      ; If $L(STR)> MAX and has no spaces, or the $L of any space-delimited

 +13      ; piece of STR > MAX, then setup spaces every MAX characters so that

 +14      ; the ^DIWP routine will "wrap" STR so that no piece's $L is > MAX.

 +15       IF NEEDSP!((STR'[$CHAR(32)&($LENGTH(STR)>MAX)))

               Begin DoDot:1

 +16               SET ONGO=STR

 +17               FOR

                       IF $LENGTH(ONGO)<MAX

                           QUIT

                       Begin DoDot:2

 +18                       SET STR1=$EXTRACT(ONGO,1,MAX)

 +19                       SET STR2=$EXTRACT(ONGO,(MAX+1),(MAX*2))

 +20                       SET WRAPSTR=WRAPSTR_STR1_" "_STR2

 +21                       SET ONGO=$EXTRACT(ONGO,((MAX*2)+1),$LENGTH(ONGO))

 +22                       IF $LENGTH(ONGO)

                               SET WRAPSTR=WRAPSTR_" "

                       End DoDot:2

 +23               IF $LENGTH(ONGO)

                       SET WRAPSTR=WRAPSTR_ONGO

               End DoDot:1

 +24      ;

 +25      ; If WRAPSTR exists, trim trailing spaces

 +26       IF $LENGTH(WRAPSTR)

               SET WRAPSTR=$$TRIM^XLFSTR(WRAPSTR,"R"," ")

 +27      ;

 +28       SET X=$SELECT($LENGTH(WRAPSTR):WRAPSTR,1:STR)

 +29      ;

 +30      ; Use FileMan DIWP routine to "wrap" string, if necessary.

 +31       KILL ^UTILITY($JOB,"W")

 +32       SET LM=2

 +33       SET DIWL=LM

           SET DIWR=""

           SET DIWF="C"_MAX

 +34       DO ^DIWP

 +35      ;

 +36      ; Use loop to output result without extra line feed

 +37       SET LINE=0

 +38       FOR

               SET LINE=$ORDER(^UTILITY($JOB,"W",LM,LINE))

               IF LINE<1

                   QUIT

               Begin DoDot:1

 +39               IF LINE=1

                       WRITE ?TAB

 +40               IF LINE>1

                       WRITE !,?TAB

                       SET LINES=1+$GET(LINES)

 +41               WRITE $$TRIM^XLFSTR($GET(^UTILITY($JOB,"W",LM,LINE,0)),"L",$CHAR(9))

               End DoDot:1

 +42      ;

 +43       KILL ^UTILITY($JOB,"W")

 +44       QUIT

 +45      ;

DASH(LEN) ; EP - Dashed Characters

 +1        WRITE $TRANSLATE($JUSTIFY("",LEN)," ","-")

 +2        QUIT ""

 +3       ;

 +4       ;

BUILDHED(STR,NOCENTER) ; EP - Build the HEADER array

 +1        NEW CURLINE

 +2       ;

 +3        SET NOCENTER=$GET(NOCENTER,1)

 +4       ;

 +5        SET CURLINE=+$ORDER(HEADER("A"),-1)+1

 +6        IF CURLINE<3!(NOCENTER)

               SET HEADER(CURLINE)=STR

               QUIT

 +7       ;

 +8        SET HEADER(CURLINE)=$$CJ^XLFSTR(STR,IOM)

 +9        QUIT

 +10      ;

 +11      ; ----- END IHS/MSC/MKK - LR*5.2*1033

 +12      ;

 +13      ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034

SHOWBOX(MSG,LM,RM) ; EP - Display Message in a "box"

 +1        NEW CRTLINE,J,MAXIT,AROUND

 +2       ;

 +3        SET RM=$GET(RM,IOM)

 +4        SET LM=$GET(LM,0)

 +5        SET RM=RM-LM

 +6       ;

 +7        SET MAXIT="@"

 +8        FOR J=1:1:$LENGTH(MSG)

               SET MAXIT=MAXIT_$EXTRACT(MSG,J,J)_"@"

 +9        SET AROUND=$TRANSLATE($JUSTIFY("",8+$LENGTH(MAXIT))," ","@")

 +10       SET MAXIT="@@!!"_$TRANSLATE(MAXIT," ","@")_"!!@@"

 +11      ;

 +12       WRITE !!

 +13       FOR J=1,2

               WRITE ?LM,$TRANSLATE($JUSTIFY("",RM)," ","*"),!

 +14       WRITE ?LM,$TRANSLATE($$CJ^XLFSTR(AROUND,RM)," @","* "),!

 +15       WRITE ?LM,$TRANSLATE($$CJ^XLFSTR(MAXIT,RM)," @","* "),!

 +16       WRITE ?LM,$TRANSLATE($$CJ^XLFSTR(AROUND,RM)," @","* "),!

 +17       FOR J=1,2

               WRITE ?LM,$TRANSLATE($JUSTIFY("",RM)," ","*"),!

 +18       QUIT

 +19      ;

COLHEAD(MSG,WIDTH,DASHER) ; EP - COLumn HEADer String

 +1        NEW COLSTR

 +2       ;

 +3        SET DASHER=$GET(DASHER,"=")

 +4        SET COLSTR="@"_$TRANSLATE(MSG," ","@")_"@"

 +5        QUIT $TRANSLATE($$CJ^XLFSTR(COLSTR,WIDTH)," @",DASHER_" ")

 +6       ;

 +7       ; ----- END IHS/MSC/MKK - LR*5.2*1034

BLRGMENU.m