QAQAHOC4 ;HISC/DAD-AD HOC REPORTS: MACRO OUTPUT ;12/30/92 11:30
;;1.7;QM Integration Module;**2,5**;07/25/1995
EN1 ; *** Set the output macro flag
S QAQMOUTP=1 W !!?3,"You will be prompted for an output",!?3,"device when you exit the ",QAQTYPE(0)," menu. ",*7
R QA:QAQDTIME
Q
EN2 ; *** Print the macro report
K %ZIS,IOP S %ZIS="QM",%ZIS("A")=" Output macro to device: " W ! D ^%ZIS G:POP EXIT I $D(IO("Q")) K IO("Q") D QVAR,^%ZTLOAD G EXIT
ENTSK K QAQUNDL S QAQEXIT=0,$P(QAQUNDL,"_",81)=""
U IO W:$E(IOST)="C" @IOF
W !?19,"=========================================="
W !?19,"|| AD HOC REPORT GENERATOR MACRO REPORT ||"
W !?19,"=========================================="
W !!!,"Report name: ",$E(QAQUNDL,1,67)
W !!,"Sort fields:",!,"------------"
W !!,"Macro: ",$S($D(QAQMACRO("S"))#2:$P(QAQMACRO("S"),"^",2),1:$E(QAQUNDL,1,73))
F QAQORDER=1:1:QAQMAXOP("S") S QAQFIELD=$O(QAQOPTN("S",QAQORDER,"")),X=$G(QAQOPTN("S",QAQORDER,+QAQFIELD)) D PS
D PAUSE G:QAQEXIT EXIT
W !!,"Print fields:",!,"-------------"
W !!,"Macro: ",$S($D(QAQMACRO("P"))#2:$P(QAQMACRO("P"),"^",2),1:$E(QAQUNDL,1,73))
F QAQORDER=1:1:QAQMAXOP("P") S QAQFIELD=$O(QAQOPTN("P",QAQORDER,"")),X=$G(QAQOPTN("P",QAQORDER,+QAQFIELD)) D PP
D PAUSE G:QAQEXIT EXIT
W !!,"Header: ",$E(QAQUNDL,1,72)
W !!,"Device: ",$E(QAQUNDL,1,72)
W:$E(IOST)'="C" @IOF
EXIT ; *** Exit the macro report
D ^%ZISC S QAQMOUTP=0
S:$D(ZTQUEUED) ZTREQ="@"
Q
PS ; *** Print the macro sort data
S X(1)=$P(X,";"),X(1)=$TR(X(1),$TR(X(1),"+-!@'#"))_QAQFIELD_$S($P(X,";")]"":";"_$P(X,";",2,99),1:"")
S X(2)=$S($G(FR(QAQORDER))]"":FR(QAQORDER),X(1)]"":"Beginning",1:""),X(3)=$S($G(TO(QAQORDER))]"":TO(QAQORDER),X(1)]"":"Ending",1:"")
I $D(QAQMACRO("S")),X(1)]"" D
. S QAQD1=0 F QA=$L(X(1),";"):-1:1 D Q:QAQD1
.. S QAQD1=$O(^QA(740.1,+QAQMACRO("S"),"FLD","B",$P(X(1),";",1,QA),0))
.. Q
. I QAQD1 D
.. S QA=$G(^QA(740.1,+QAQMACRO("S"),"FLD",QAQD1,0)),QAQ=$G(^("FRTO"))
.. S X(1)=$P(QA,"^")
.. F QAI=1,2 S X(QAI+1)=$S($P(QA,"^",3):"Ask User",$P(QAQ,"^",QAI)]"":$E($P(QAQ,"^",QAI),1,30),QAI=1:"Beginning",1:"Ending")
.. Q
. Q
PS1 ; *** Inquire sort macro entry point
S QA=$G(QAQMENU(+QAQFIELD)),QA=$S(QA'>0:"",1:$P(QA,"^",2))
W !!?3,QAQORDER,") Field: ",$S(QA]"":QA,QAQFIELD?1.N:"*** CORRUPTED ***",1:$E(QAQUNDL,1,30))
F XX=1:1:$L(X(1)) I "'!@#&+-"[$E(X(1)) S X(1)=$E(X(1),2,999)
W !?6,"Entry: ",$S(X(1)]"":X(1),1:$E(QAQUNDL,1,30))
W !?6,"From: ",$E($S(X(2)]"":X(2),1:QAQUNDL),1,30)
W ?46,"To: ",$E($S(X(3)]"":X(3),1:QAQUNDL),1,30)
Q
PP ; *** Print the macro print data
S X(1)=$P(X,";"),X(1)=$TR(X(1),$TR(X(1),"&!+#"))_QAQFIELD_$S($P(X,";",2)]"":";"_$P(X,";",2,99),1:"")
I $D(QAQMACRO("P")),X(1)]"" D
. S QAQD1=0 F QA=$L(X(1),";"):-1:1 D Q:QAQD1
.. S QAQD1=$O(^QA(740.1,+QAQMACRO("P"),"FLD","B",$P(X(1),";",1,QA),0))
.. Q
. I QAQD1 S X(1)=$P($G(^QA(740.1,+QAQMACRO("P"),"FLD",QAQD1,0)),"^")
. Q
PP1 ; *** Inquire print macro entry point
S QA=$P($G(QAQMENU(+QAQFIELD)),"^",2)
W !!?3,QAQORDER,") Field: ",$S(QA]"":QA,QAQFIELD?1.N:"*** CORRUPTED ***",1:$E(QAQUNDL,1,30))
F XX=1:1:$L(X(1)) I "'!@#&+-"[$E(X(1)) S X(1)=$E(X(1),2,999)
W !?6,"Entry: ",$S(X(1)]"":X(1),1:$E(QAQUNDL,1,30))
Q
PAUSE ; *** Pause at the end of page
I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S QAQEXIT=$S(Y'>0:1,1:0)
Q
QVAR ; *** Save variables for queueing
S ZTRTN="ENTSK^QAQAHOC4",ZTDESC="Ad Hoc Report Generator Macro Report"
F QA="FR","QAQMAXOP(","QAQMENU(","QAQOPTN(","QAQTEMP","QAQMACRO(","TO" S ZTSAVE(QA)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAQAHOC4 3550 printed Oct 16, 2024@18:31:58 Page 2
QAQAHOC4 ;HISC/DAD-AD HOC REPORTS: MACRO OUTPUT ;12/30/92 11:30
+1 ;;1.7;QM Integration Module;**2,5**;07/25/1995
EN1 ; *** Set the output macro flag
+1 SET QAQMOUTP=1
WRITE !!?3,"You will be prompted for an output",!?3,"device when you exit the ",QAQTYPE(0)," menu. ",*7
+2 READ QA:QAQDTIME
+3 QUIT
EN2 ; *** Print the macro report
+1 KILL %ZIS,IOP
SET %ZIS="QM"
SET %ZIS("A")=" Output macro to device: "
WRITE !
DO ^%ZIS
if POP
GOTO EXIT
IF $DATA(IO("Q"))
KILL IO("Q")
DO QVAR
DO ^%ZTLOAD
GOTO EXIT
ENTSK KILL QAQUNDL
SET QAQEXIT=0
SET $PIECE(QAQUNDL,"_",81)=""
+1 USE IO
if $EXTRACT(IOST)="C"
WRITE @IOF
+2 WRITE !?19,"=========================================="
+3 WRITE !?19,"|| AD HOC REPORT GENERATOR MACRO REPORT ||"
+4 WRITE !?19,"=========================================="
+5 WRITE !!!,"Report name: ",$EXTRACT(QAQUNDL,1,67)
+6 WRITE !!,"Sort fields:",!,"------------"
+7 WRITE !!,"Macro: ",$SELECT($DATA(QAQMACRO("S"))#2:$PIECE(QAQMACRO("S"),"^",2),1:$EXTRACT(QAQUNDL,1,73))
+8 FOR QAQORDER=1:1:QAQMAXOP("S")
SET QAQFIELD=$ORDER(QAQOPTN("S",QAQORDER,""))
SET X=$GET(QAQOPTN("S",QAQORDER,+QAQFIELD))
DO PS
+9 DO PAUSE
if QAQEXIT
GOTO EXIT
+10 WRITE !!,"Print fields:",!,"-------------"
+11 WRITE !!,"Macro: ",$SELECT($DATA(QAQMACRO("P"))#2:$PIECE(QAQMACRO("P"),"^",2),1:$EXTRACT(QAQUNDL,1,73))
+12 FOR QAQORDER=1:1:QAQMAXOP("P")
SET QAQFIELD=$ORDER(QAQOPTN("P",QAQORDER,""))
SET X=$GET(QAQOPTN("P",QAQORDER,+QAQFIELD))
DO PP
+13 DO PAUSE
if QAQEXIT
GOTO EXIT
+14 WRITE !!,"Header: ",$EXTRACT(QAQUNDL,1,72)
+15 WRITE !!,"Device: ",$EXTRACT(QAQUNDL,1,72)
+16 if $EXTRACT(IOST)'="C"
WRITE @IOF
EXIT ; *** Exit the macro report
+1 DO ^%ZISC
SET QAQMOUTP=0
+2 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 QUIT
PS ; *** Print the macro sort data
+1 SET X(1)=$PIECE(X,";")
SET X(1)=$TRANSLATE(X(1),$TRANSLATE(X(1),"+-!@'#"))_QAQFIELD_$SELECT($PIECE(X,";")]"":";"_$PIECE(X,";",2,99),1:"")
+2 SET X(2)=$SELECT($GET(FR(QAQORDER))]"":FR(QAQORDER),X(1)]"":"Beginning",1:"")
SET X(3)=$SELECT($GET(TO(QAQORDER))]"":TO(QAQORDER),X(1)]"":"Ending",1:"")
+3 IF $DATA(QAQMACRO("S"))
IF X(1)]""
Begin DoDot:1
+4 SET QAQD1=0
FOR QA=$LENGTH(X(1),";"):-1:1
Begin DoDot:2
+5 SET QAQD1=$ORDER(^QA(740.1,+QAQMACRO("S"),"FLD","B",$PIECE(X(1),";",1,QA),0))
+6 QUIT
End DoDot:2
if QAQD1
QUIT
+7 IF QAQD1
Begin DoDot:2
+8 SET QA=$GET(^QA(740.1,+QAQMACRO("S"),"FLD",QAQD1,0))
SET QAQ=$GET(^("FRTO"))
+9 SET X(1)=$PIECE(QA,"^")
+10 FOR QAI=1,2
SET X(QAI+1)=$SELECT($PIECE(QA,"^",3):"Ask User",$PIECE(QAQ,"^",QAI)]"":$EXTRACT($PIECE(QAQ,"^",QAI),1,30),QAI=1:"Beginning",1:"Ending")
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
PS1 ; *** Inquire sort macro entry point
+1 SET QA=$GET(QAQMENU(+QAQFIELD))
SET QA=$SELECT(QA'>0:"",1:$PIECE(QA,"^",2))
+2 WRITE !!?3,QAQORDER,") Field: ",$SELECT(QA]"":QA,QAQFIELD?1.N:"*** CORRUPTED ***",1:$EXTRACT(QAQUNDL,1,30))
+3 FOR XX=1:1:$LENGTH(X(1))
IF "'!@#&+-"[$EXTRACT(X(1))
SET X(1)=$EXTRACT(X(1),2,999)
+4 WRITE !?6,"Entry: ",$SELECT(X(1)]"":X(1),1:$EXTRACT(QAQUNDL,1,30))
+5 WRITE !?6,"From: ",$EXTRACT($SELECT(X(2)]"":X(2),1:QAQUNDL),1,30)
+6 WRITE ?46,"To: ",$EXTRACT($SELECT(X(3)]"":X(3),1:QAQUNDL),1,30)
+7 QUIT
PP ; *** Print the macro print data
+1 SET X(1)=$PIECE(X,";")
SET X(1)=$TRANSLATE(X(1),$TRANSLATE(X(1),"&!+#"))_QAQFIELD_$SELECT($PIECE(X,";",2)]"":";"_$PIECE(X,";",2,99),1:"")
+2 IF $DATA(QAQMACRO("P"))
IF X(1)]""
Begin DoDot:1
+3 SET QAQD1=0
FOR QA=$LENGTH(X(1),";"):-1:1
Begin DoDot:2
+4 SET QAQD1=$ORDER(^QA(740.1,+QAQMACRO("P"),"FLD","B",$PIECE(X(1),";",1,QA),0))
+5 QUIT
End DoDot:2
if QAQD1
QUIT
+6 IF QAQD1
SET X(1)=$PIECE($GET(^QA(740.1,+QAQMACRO("P"),"FLD",QAQD1,0)),"^")
+7 QUIT
End DoDot:1
PP1 ; *** Inquire print macro entry point
+1 SET QA=$PIECE($GET(QAQMENU(+QAQFIELD)),"^",2)
+2 WRITE !!?3,QAQORDER,") Field: ",$SELECT(QA]"":QA,QAQFIELD?1.N:"*** CORRUPTED ***",1:$EXTRACT(QAQUNDL,1,30))
+3 FOR XX=1:1:$LENGTH(X(1))
IF "'!@#&+-"[$EXTRACT(X(1))
SET X(1)=$EXTRACT(X(1),2,999)
+4 WRITE !?6,"Entry: ",$SELECT(X(1)]"":X(1),1:$EXTRACT(QAQUNDL,1,30))
+5 QUIT
PAUSE ; *** Pause at the end of page
+1 IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
SET QAQEXIT=$SELECT(Y'>0:1,1:0)
+2 QUIT
QVAR ; *** Save variables for queueing
+1 SET ZTRTN="ENTSK^QAQAHOC4"
SET ZTDESC="Ad Hoc Report Generator Macro Report"
+2 FOR QA="FR","QAQMAXOP(","QAQMENU(","QAQOPTN(","QAQTEMP","QAQMACRO(","TO"
SET ZTSAVE(QA)=""
+3 QUIT
