- 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
