ORGUEM3 ; slc/KCM - Setup Formatted Protocol Menus (cont) ;7/13/92 15:40
;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
;;
HLP ;Provide help for ORCL PROTOCOL MENU SETUP menu
N ORGPOP
I X="?" D G HLPX
. D DISP^XQORM1
. W !!
I X["??" D G HLPX
. N Y D SEQ(+XQORNOD,.Y)
. S (DX,DY)=0 X ^%ZOSF("XY")
. F I=1:1:Y I ^ORD(101,$P(Y(I),"^",2),0)'?1"ORB".E D Q:$D(ORGPOP)
. . W !,$P(^ORD(101,+XQORNOD,10,+Y(I),0),"^",2)
. . S J=0 F S J=$O(^ORD(101,$P(Y(I),"^",2),1,J)) Q:J'>0 D Q:$D(ORGPOP)
. . . W ?5,^ORD(101,$P(Y(I),"^",2),1,J,0),!
. . . I $Y>22 D
. . . . W "Press RETURN to continue or '^' to exit: "
. . . . R X:DTIME S:'$T!(X["^") ORGPOP=1 W $C(13)
. . . . S (DX,DY)=0 X ^%ZOSF("XY")
. W !
HLPX Q
SEQ(PCL,Y) ; For the named protocol (PCL) return array of items in sequence
; Y must be call by reference, returned is Y(n)=item ien^protocol
N X,SEQ,ITM K Y ;(make sure Y is empty)
S Y=0 ; Y is returned 0 if no items found
S ITM=0 F S ITM=$O(^ORD(101,PCL,10,ITM)) Q:ITM'>0 D
. S X=^ORD(101,PCL,10,ITM,0)
. ;precedence for sequence is SEQUENCE, numeric MNEMONIC, alpha MNEMONIC, alpha ITEM TEXT
. S SEQ=$S(+$P(X,"^",3):+$P(X,"^",3),+$P(X,"^",2):+$P(X,"^",2),$L($P(X,"^",2)):"M"_$P(X,"^",2),1:"Z"_$P(^ORD(101,+X,0),"^",2))
. S X(SEQ,ITM)=+X
S SEQ="" F S SEQ=$O(X(SEQ)) Q:SEQ="" D
. S ITM="" F S ITM=$O(X(SEQ,ITM)) Q:ITM="" D
. . S Y=Y+1,Y(Y)=ITM_"^"_X(SEQ,ITM)
Q
LIST ; List protocols on menu
S %ZIS="Q" D ^%ZIS I POP D HOME^%ZIS Q
I $D(IO("Q")) D Q
. K IO("Q")
. S ZTRTN="DQ^ORGUEM3",ZTDESC="List Menu Items",ZTSAVE("ORGMENU")=""
. D ^%ZTLOAD W:$D(ZTSK) !,"List queued." K ZTSK
. D HOME^%ZIS
DQ U IO N CTM,EOP,ITM,LIST
D SEQ(+ORGMENU,.LIST)
S %DT="T",X="NOW" D ^%DT,DD^%DT S CTM=Y
I $E(IOST)="C" W @IOF,$C(13)
D HDR1
F ITM=1:1:LIST S EOP=$$EOP(2) Q:EOP=-1 D:EOP=1 HDR D PITM(LIST(ITM))
I $E(IOST)'="C" W @IOF
I $D(ZTQUEUED) S ZTREQ="@"
I '$D(ZTQUEUED) D ^%ZISC
Q
HDR ; Print header
W @IOF,$C(13)
HDR1 W "Menu: ",$P(ORGMENU,"^",2),?61,CTM,!!
Q
PITM(X) ; Print item fields
; ITEM: 123 Displayed Text ?64 SEQUENCE: 99.00
; NAME: NAME OF PROTOCOL (ITEM TEXT)
W "ITEM: "
I $P(^ORD(101,$P(X,"^",2),0),"^",2)?." " W "<blank line>"
E D
. W $P(^ORD(101,+ORGMENU,10,+X,0),"^",2)
. W ?(6+$S($P($G(^ORD(101,+ORGMENU,4)),"^",2):$P(^(4),"^",2),1:5))
. W $S($L($P(^ORD(101,+ORGMENU,10,+X,0),"^",6)):$P(^(0),"^",6),1:$P(^ORD(101,$P(X,"^",2),0),"^",2))
W ?64,"SEQUENCE: ",$S($L($P(^ORD(101,+ORGMENU,10,+X,0),"^",3)):$J($P(^(0),"^",3),5,2),1:""),!
W "PROTOCOL: ",$P(^ORD(101,$P(X,"^",2),0),"^")," "
I $P(^ORD(101,$P(X,"^",2),0),"^",2)'?1." ",$L($P(^(0),"^",2)) W "(",$P(^(0),"^",2),")"
W !!
Q
EOP(LINES) ; Check if end of page, handle CRT & printer advance
I $Y<(IOSL-LINES) Q 0
I $E(IOST)="C" D Q:X["^" -1
. W "Press RETURN to continue or '^' to exit: "
. R X:DTIME
Q 1
ORGUEM3 ; slc/KCM - Setup Formatted Protocol Menus (cont) ;7/13/92 15:40
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
+2 ;;
HLP ;Provide help for ORCL PROTOCOL MENU SETUP menu
+1 NEW ORGPOP
+2 IF X="?"
Begin DoDot:1
+3 DO DISP^XQORM1
+4 WRITE !!
End DoDot:1
GOTO HLPX
+5 IF X["??"
Begin DoDot:1
+6 NEW Y
DO SEQ(+XQORNOD,.Y)
+7 SET (DX,DY)=0
XECUTE ^%ZOSF("XY")
+8 FOR I=1:1:Y
IF ^ORD(101,$PIECE(Y(I),"^",2),0)'?1"ORB".E
Begin DoDot:2
+9 WRITE !,$PIECE(^ORD(101,+XQORNOD,10,+Y(I),0),"^",2)
+10 SET J=0
FOR
SET J=$ORDER(^ORD(101,$PIECE(Y(I),"^",2),1,J))
IF J'>0
QUIT
Begin DoDot:3
+11 WRITE ?5,^ORD(101,$PIECE(Y(I),"^",2),1,J,0),!
+12 IF $Y>22
Begin DoDot:4
+13 WRITE "Press RETURN to continue or '^' to exit: "
+14 READ X:DTIME
IF '$TEST!(X["^")
SET ORGPOP=1
WRITE $CHAR(13)
+15 SET (DX,DY)=0
XECUTE ^%ZOSF("XY")
End DoDot:4
End DoDot:3
IF $DATA(ORGPOP)
QUIT
End DoDot:2
IF $DATA(ORGPOP)
QUIT
+16 WRITE !
End DoDot:1
GOTO HLPX
HLPX QUIT
SEQ(PCL,Y) ; For the named protocol (PCL) return array of items in sequence
+1 ; Y must be call by reference, returned is Y(n)=item ien^protocol
+2 ;(make sure Y is empty)
NEW X,SEQ,ITM
KILL Y
+3 ; Y is returned 0 if no items found
SET Y=0
+4 SET ITM=0
FOR
SET ITM=$ORDER(^ORD(101,PCL,10,ITM))
IF ITM'>0
QUIT
Begin DoDot:1
+5 SET X=^ORD(101,PCL,10,ITM,0)
+6 ;precedence for sequence is SEQUENCE, numeric MNEMONIC, alpha MNEMONIC, alpha ITEM TEXT
+7 SET SEQ=$SELECT(+$PIECE(X,"^",3):+$PIECE(X,"^",3),+$PIECE(X,"^",2):+$PIECE(X,"^",2),$LENGTH($PIECE(X,"^",2)):"M"_$PIECE(X,"^",2),1:"Z"_$PIECE(^ORD(101,+X,0),"^",2))
+8 SET X(SEQ,ITM)=+X
End DoDot:1
+9 SET SEQ=""
FOR
SET SEQ=$ORDER(X(SEQ))
IF SEQ=""
QUIT
Begin DoDot:1
+10 SET ITM=""
FOR
SET ITM=$ORDER(X(SEQ,ITM))
IF ITM=""
QUIT
Begin DoDot:2
+11 SET Y=Y+1
SET Y(Y)=ITM_"^"_X(SEQ,ITM)
End DoDot:2
End DoDot:1
+12 QUIT
LIST ; List protocols on menu
+1 SET %ZIS="Q"
DO ^%ZIS
IF POP
DO HOME^%ZIS
QUIT
+2 IF $DATA(IO("Q"))
Begin DoDot:1
+3 KILL IO("Q")
+4 SET ZTRTN="DQ^ORGUEM3"
SET ZTDESC="List Menu Items"
SET ZTSAVE("ORGMENU")=""
+5 DO ^%ZTLOAD
IF $DATA(ZTSK)
WRITE !,"List queued."
KILL ZTSK
+6 DO HOME^%ZIS
End DoDot:1
QUIT
DQ USE IO
NEW CTM,EOP,ITM,LIST
+1 DO SEQ(+ORGMENU,.LIST)
+2 SET %DT="T"
SET X="NOW"
DO ^%DT
DO DD^%DT
SET CTM=Y
+3 IF $EXTRACT(IOST)="C"
WRITE @IOF,$CHAR(13)
+4 DO HDR1
+5 FOR ITM=1:1:LIST
SET EOP=$$EOP(2)
IF EOP=-1
QUIT
IF EOP=1
DO HDR
DO PITM(LIST(ITM))
+6 IF $EXTRACT(IOST)'="C"
WRITE @IOF
+7 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+8 IF '$DATA(ZTQUEUED)
DO ^%ZISC
+9 QUIT
HDR ; Print header
+1 WRITE @IOF,$CHAR(13)
HDR1 WRITE "Menu: ",$PIECE(ORGMENU,"^",2),?61,CTM,!!
+1 QUIT
PITM(X) ; Print item fields
+1 ; ITEM: 123 Displayed Text ?64 SEQUENCE: 99.00
+2 ; NAME: NAME OF PROTOCOL (ITEM TEXT)
+3 WRITE "ITEM: "
+4 IF $PIECE(^ORD(101,$PIECE(X,"^",2),0),"^",2)?." "
WRITE "<blank line>"
+5 IF '$TEST
Begin DoDot:1
+6 WRITE $PIECE(^ORD(101,+ORGMENU,10,+X,0),"^",2)
+7 WRITE ?(6+$SELECT($PIECE($GET(^ORD(101,+ORGMENU,4)),"^",2):$PIECE(^(4),"^",2),1:5))
+8 WRITE $SELECT($LENGTH($PIECE(^ORD(101,+ORGMENU,10,+X,0),"^",6)):$PIECE(^(0),"^",6),1:$PIECE(^ORD(101,$PIECE(X,"^",2),0),"^",2))
End DoDot:1
+9 WRITE ?64,"SEQUENCE: ",$SELECT($LENGTH($PIECE(^ORD(101,+ORGMENU,10,+X,0),"^",3)):$JUSTIFY($PIECE(^(0),"^",3),5,2),1:""),!
+10 WRITE "PROTOCOL: ",$PIECE(^ORD(101,$PIECE(X,"^",2),0),"^")," "
+11 IF $PIECE(^ORD(101,$PIECE(X,"^",2),0),"^",2)'?1." "
IF $LENGTH($PIECE(^(0),"^",2))
WRITE "(",$PIECE(^(0),"^",2),")"
+12 WRITE !!
+13 QUIT
EOP(LINES) ; Check if end of page, handle CRT & printer advance
+1 IF $Y<(IOSL-LINES)
QUIT 0
+2 IF $EXTRACT(IOST)="C"
Begin DoDot:1
+3 WRITE "Press RETURN to continue or '^' to exit: "
+4 READ X:DTIME
End DoDot:1
IF X["^"
QUIT -1
+5 QUIT 1
