LROPTLST ;SLC/FHS - LIST OPTIONS FOR VERIFICATION ;2/19/91 11:10 ;
;;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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLROPTLST 2333 printed Nov 22, 2024@17:28:39 Page 2
LROPTLST ;SLC/FHS - LIST OPTIONS FOR VERIFICATION ;2/19/91 11:10 ;
+1 ;;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
