QAQAHOC4.m

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 ---QAQAHOC4   3550     printed  Feb 18, 2025@23:57:45                                                                                                                                                                                                    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