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),!
Q
;
; Display up to 4 Header lines
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
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
Q
;
; 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
Q
;
; 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
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
Q
;
; Display BLRMMENU array -- Tab positions are hardcoded
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 !
Q
;
; 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 !
Q
;
; New Page with just Header & Date & Time
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
;
Q
;
; Header with Date/Time & Page Numbers
BLRGHWPN(PG,QFLG,HEADONE) ; EP
D HEDPGNUM
Q
;
; HEaDer with PaGe Number & date/time
D HEDPGNUM
Q
;
; 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
;
Q
;
; 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
;
Q
;
; 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
;
Q
;
; 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")
Q
;
; ----- 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")
Q
;
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)
Q
;
; ----- 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)," ","*"),!
Q
;
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
+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
+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
+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
+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
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
+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
