- LROPTLST ; IHS/DIR/FJE - LIST OPTIONS FOR VERIFICATION 2/19/91 11:10 ;
- ;;5.2;LR;**1013**;JUL 15, 2002
- ;
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- EN ;
- S OK=1
- S OPTN=$S($D(OPTN):OPTN,1:"LRMENU")
- K IO("Q") S:$D(ZTQUEUED) ZTREQ="@" S OPT=$O(^DIC(19,"B",OPTN,0)) Q:OPT<1 K ^TMP($J),MENU,^TMP("OPT") S $P(LINE,"-",IOM)="",CNT=0,U="^"
- F I=0:0 S I=$O(^DIC(19,OPT,10,"B",I)) Q:I="" S ^TMP($J,I)=""
- SUB ;
- F I=0:0 S I=$O(^TMP($J,I)) Q:I<1 D:'$D(^DIC(19,I,10)) SORTI I $D(^DIC(19,I,10,"B")) W !!,LINE,!,$P(^DIC(19,I,0),U),!! F II=0:0 S II=$O(^DIC(19,I,10,"B",II)) D:II="" MSUB Q:II="" D SORT I 'OK G END
- SUB1 ;
- K MENU F I=0:0 S I=$O(^TMP($J,I)) Q:I<1 S MENU($P(^DIC(19,I,0),U,2))=I
- S O="" F A=0:0 S O=$O(MENU(O)) Q:O="" S I=MENU(O),PG=0 D HEAD S MTX="" F A=0:0 S MTX=$O(^TMP($J,"OPT",I,MTX)) Q:MTX="" S OPT=^(MTX) D PRT1
- W !!,LINE,!!?20,"TOTAL OPTIONS = ",CNT,!! W:$E(IOST,1,2)'="C-" @IOF
- END K CNT,OPTN,PG,O,I,II,A,OPT,MENU,LINE,IX,IO("Q"),DIC,%ZIS,DIS,MTX,X,^TMP($J) D ^%ZISC W !!?20," ******** END OF LISTING ********",!
- Q
- MSUB ;
- S II="",II=$O(MENU(I,II)) Q:II="" D SORT K MENU(I,II) G MSUB
- Q
- SORTI S II=I
- SORT ;
- I '$D(^DIC(19,II,0)) W !,"ERROR OPTION "_II_" IS MISSING " S OK=0 Q
- I $P(^DIC(19,II,0),U,4)="M" S IX="" F A=0:0 S IX=$O(^DIC(19,II,10,"B",IX)) Q:IX="" S MENU(I,IX)=""
- PRT ;
- I $P(^DIC(19,II,0),U,4)="M" Q
- S X=^DIC(19,II,0),OPT=$P(X,U),MTX=$P(X,U,2) I $D(^DIC(19,II,25)),$L(^(25)) S OPT=OPT_" ( "_^(25)_" ) "
- S ^TMP($J,"OPT",I,MTX)=OPT F DIS=0:0 S DIS=$O(^DIC(19,II,1,DIS)) Q:DIS="" S ^TMP($J,"OPT",I,MTX,1,DIS,0)=^(DIS,0)
- Q
- PRT1 ;
- I $Y>60 D HEAD
- S CNT=CNT+1 W !,MTX,?45,OPT F DIS=0:0 S DIS=$O(^TMP($J,"OPT",I,MTX,1,DIS)) Q:DIS="" W !,?5,^(DIS,0) I $Y>60 D HEAD W !,MTX,?40,OPT,!!?30,"<<< CONTINUED >>>",!
- W !!?20,$E(LINE,1,40),!
- Q
- QUE ;
- K DIC S DIC=19,DIC(0)="AEQM",DIC("S")="I $P(^(0),U,4)=""M""&($E(^(0),1,2)[""LR"")!($E(^(0),1,2)[""LA"")" D ^DIC G END:Y<1
- I '$O(^DIC(19,+Y,10,"B",0)) W !!?10,"THERE ARE NO ITEMS ON THE MENU ",$C(7) G END
- S OPTN=$P(Y,U,2) K IO("Q"),%ZIS S %ZIS="QN",%ZIS("A")="PRINTER DEVICE: " D ^%ZIS Q:POP I IO=IO(0) G EN
- S ZTSAVE("OPTN")="",ZTRTN="LROPTLST",ZTDESC="LIST OF MENU OPTIONS ",ZTIO=ION D ^%ZTLOAD
- W !,"QUEUED TO DEVICE ",ION D ^%ZISC K IO("Q") Q
- HEAD ;
- S PG=PG+1 W @IOF,!!!?10,"*************** ",$P(^DIC(19,I,0),U,2)," ****************** PG ",PG,!! Q
- LROPTLST ; IHS/DIR/FJE - LIST OPTIONS FOR VERIFICATION 2/19/91 11:10 ;
- +1 ;;5.2;LR;**1013**;JUL 15, 2002
- +2 ;
- +3 ;;5.2;LAB SERVICE;;Sep 27, 1994
- EN ;
- +1 SET OK=1
- +2 SET OPTN=$SELECT($DATA(OPTN):OPTN,1:"LRMENU")
- +3 KILL IO("Q")
- IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- SET OPT=$ORDER(^DIC(19,"B",OPTN,0))
- IF OPT<1
- QUIT
- KILL ^TMP($JOB),MENU,^TMP("OPT")
- SET $PIECE(LINE,"-",IOM)=""
- SET CNT=0
- SET U="^"
- +4 FOR I=0:0
- SET I=$ORDER(^DIC(19,OPT,10,"B",I))
- IF I=""
- QUIT
- SET ^TMP($JOB,I)=""
- SUB ;
- +1 FOR I=0:0
- SET I=$ORDER(^TMP($JOB,I))
- IF I<1
- QUIT
- IF '$DATA(^DIC(19,I,10))
- DO SORTI
- IF $DATA(^DIC(19,I,10,"B"))
- WRITE !!,LINE,!,$PIECE(^DIC(19,I,0),U),!!
- FOR II=0:0
- SET II=$ORDER(^DIC(19,I,10,"B",II))
- IF II=""
- DO MSUB
- IF II=""
- QUIT
- DO SORT
- IF 'OK
- GOTO END
- SUB1 ;
- +1 KILL MENU
- FOR I=0:0
- SET I=$ORDER(^TMP($JOB,I))
- IF I<1
- QUIT
- SET MENU($PIECE(^DIC(19,I,0),U,2))=I
- +2 SET O=""
- FOR A=0:0
- SET O=$ORDER(MENU(O))
- IF O=""
- QUIT
- SET I=MENU(O)
- SET PG=0
- DO HEAD
- SET MTX=""
- FOR A=0:0
- SET MTX=$ORDER(^TMP($JOB,"OPT",I,MTX))
- IF MTX=""
- QUIT
- SET OPT=^(MTX)
- DO PRT1
- +3 WRITE !!,LINE,!!?20,"TOTAL OPTIONS = ",CNT,!!
- IF $EXTRACT(IOST,1,2)'="C-"
- WRITE @IOF
- END KILL CNT,OPTN,PG,O,I,II,A,OPT,MENU,LINE,IX,IO("Q"),DIC,%ZIS,DIS,MTX,X,^TMP($JOB)
- DO ^%ZISC
- WRITE !!?20," ******** END OF LISTING ********",!
- +1 QUIT
- MSUB ;
- +1 SET II=""
- SET II=$ORDER(MENU(I,II))
- IF II=""
- QUIT
- DO SORT
- KILL MENU(I,II)
- GOTO MSUB
- +2 QUIT
- SORTI SET II=I
- SORT ;
- +1 IF '$DATA(^DIC(19,II,0))
- WRITE !,"ERROR OPTION "_II_" IS MISSING "
- SET OK=0
- QUIT
- +2 IF $PIECE(^DIC(19,II,0),U,4)="M"
- SET IX=""
- FOR A=0:0
- SET IX=$ORDER(^DIC(19,II,10,"B",IX))
- IF IX=""
- QUIT
- SET MENU(I,IX)=""
- PRT ;
- +1 IF $PIECE(^DIC(19,II,0),U,4)="M"
- QUIT
- +2 SET X=^DIC(19,II,0)
- SET OPT=$PIECE(X,U)
- SET MTX=$PIECE(X,U,2)
- IF $DATA(^DIC(19,II,25))
- IF $LENGTH(^(25))
- SET OPT=OPT_" ( "_^(25)_" ) "
- +3 SET ^TMP($JOB,"OPT",I,MTX)=OPT
- FOR DIS=0:0
- SET DIS=$ORDER(^DIC(19,II,1,DIS))
- IF DIS=""
- QUIT
- SET ^TMP($JOB,"OPT",I,MTX,1,DIS,0)=^(DIS,0)
- +4 QUIT
- PRT1 ;
- +1 IF $Y>60
- DO HEAD
- +2 SET CNT=CNT+1
- WRITE !,MTX,?45,OPT
- FOR DIS=0:0
- SET DIS=$ORDER(^TMP($JOB,"OPT",I,MTX,1,DIS))
- IF DIS=""
- QUIT
- WRITE !,?5,^(DIS,0)
- IF $Y>60
- DO HEAD
- WRITE !,MTX,?40,OPT,!!?30,"<<< CONTINUED >>>",!
- +3 WRITE !!?20,$EXTRACT(LINE,1,40),!
- +4 QUIT
- QUE ;
- +1 KILL DIC
- SET DIC=19
- SET DIC(0)="AEQM"
- SET DIC("S")="I $P(^(0),U,4)=""M""&($E(^(0),1,2)[""LR"")!($E(^(0),1,2)[""LA"")"
- DO ^DIC
- IF Y<1
- GOTO END
- +2 IF '$ORDER(^DIC(19,+Y,10,"B",0))
- WRITE !!?10,"THERE ARE NO ITEMS ON THE MENU ",$CHAR(7)
- GOTO END
- +3 SET OPTN=$PIECE(Y,U,2)
- KILL IO("Q"),%ZIS
- SET %ZIS="QN"
- SET %ZIS("A")="PRINTER DEVICE: "
- DO ^%ZIS
- IF POP
- QUIT
- IF IO=IO(0)
- GOTO EN
- +4 SET ZTSAVE("OPTN")=""
- SET ZTRTN="LROPTLST"
- SET ZTDESC="LIST OF MENU OPTIONS "
- SET ZTIO=ION
- DO ^%ZTLOAD
- +5 WRITE !,"QUEUED TO DEVICE ",ION
- DO ^%ZISC
- KILL IO("Q")
- QUIT
- HEAD ;
- +1 SET PG=PG+1
- WRITE @IOF,!!!?10,"*************** ",$PIECE(^DIC(19,I,0),U,2)," ****************** PG ",PG,!!
- QUIT
