QAQAHOC3 ;HISC/DAD-AD HOC REPORTS: MACRO MANAGEMENT ;7/12/93 14:35
;;1.7;QM Integration Module;**1,2,5**;07/25/1995
;
S QAQSELOP=$E(QAQSELOP,2,999) S:QAQSELOP?1L QAQSELOP=$C($A(QAQSELOP)-32)
I "^S^L^I^D^O^"'[("^"_QAQSELOP_"^") S QAQSELOP=-1 Q
W $P($P("^Save^Load^Inquire^Delete^Output^","^"_QAQSELOP,2),"^")," ",$S(QAQSELOP'="O":QAQTYPE(0)_" ",1:""),"macro"
I $D(^QA(740.1,0))[0 W *7,!!?3,"The Ad Hoc Macro file does not exist !!" S QAQSELOP=0 R QA:QAQDTIME Q
D SETSAVE:QAQSELOP="S",LOAD:QAQSELOP="L",INQUIRE:QAQSELOP="I",DELETE:QAQSELOP="D",EN1^QAQAHOC4:QAQSELOP="O"
Q
SETSAVE ; *** Set the save macro flag
S QAQMSAVE=1 W !!?3,"The macro will be saved when you exit the ",QAQTYPE(0)," menu. ",*7 I QAQSEQ=1 R QA:QAQDTIME Q
SAVEOUT W !!?3,"OK to exit now" S %=1 D YN^DICN I '% W !!?5,QAQYESNO G SAVEOUT
S:%=1 QAQNEXT=1 S:%=-1 (QAQNEXT,QAQQUIT)=1
Q
SAVE ; *** Save a sort/print macro
K DIC,QAQMACRO(QAQTYPE) S DIC(0)="AELMNQZ",DIC("A")="Save" D ASKMAC Q:Y'>0
I $P(Y,"^",3)'>0 W *7 D G SAVE:QAQREPLC=2 Q:QAQREPLC=-1
REPLACE . W !!?3,QAQTEMP," already exists, OK to replace"
. S %=2 D YN^DICN S QAQREPLC=% I '% W !!?5,QAQYESNO G REPLACE
. Q:%'=1
. F QAQD1=0:0 S QAQD1=$O(^QA(740.1,QAQD0,"FLD",QAQD1)) Q:QAQD1'>0 D
.. S (D0,DA(1))=QAQD0,(D1,DA)=QAQD1,DIK="^QA(740.1,"_QAQD0_",""FLD"","
.. D ^DIK
.. Q
. Q
S (QAQFLDNO,%)=0
F QAQORDER=0:0 S QAQORDER=$O(QAQOPTN(QAQTYPE,QAQORDER)) Q:(QAQORDER'>0)!(%=-1) F QAQFIELD=0:0 S QAQFIELD=$O(QAQOPTN(QAQTYPE,QAQORDER,QAQFIELD)) Q:(QAQFIELD'>0)!(%=-1) D
SV . I QAQTYPE="S" W !!?3,"Ask user BEGINNING/ENDING values for ",$P(QAQMENU(QAQFIELD),"^",2) S %=2 D YN^DICN Q:%=-1 I '% W !!?5,QAQYESNO G SV
. S X=QAQPREFX(QAQTYPE,QAQORDER)_QAQFIELD_QAQSUFFX(QAQTYPE,QAQORDER)_"^"_QAQOPTN(QAQTYPE,QAQORDER,QAQFIELD)_"^"_$S(QAQTYPE="S":(%=1),1:"")
. S ^QA(740.1,QAQD0,"FLD",QAQORDER,0)=X,QAQFLDNO=QAQFLDNO+1
. I QAQTYPE="S" S ^QA(740.1,QAQD0,"FLD",QAQORDER,"FRTO")=$S(%=2:QAQBEGIN(QAQORDER)_"^"_QAQEND(QAQORDER),1:"^")
. E K ^QA(740.1,QAQD0,"FLD",QAQORDER,"FRTO")
. Q
I %=-1 S DIK="^QA(740.1,",DA=QAQD0 D ^DIK S QAQMSAVE=0 W !!?3,"Sort macro ",QAQTEMP," not saved !! ",*7 R QA:QAQDTIME Q
S $P(^QA(740.1,QAQD0,0),"^",2,4)=$TR(QAQTYPE,"SP","sp")_"^"_QAQDIC_"^"_QAQCHKSM
S ^QA(740.1,QAQD0,"FLD",0)="^"_$P(^DD(740.1,1,0),"^",2)_"^"_QAQFLDNO_"^"_QAQFLDNO,DIK="^QA(740.1,",DA=QAQD0 D IX1^DIK
S QAQMACRO(QAQTYPE)=QAQTEMP(QAQTYPE)
Q
LOAD ; *** Load a sort/print macro
S QAQMLOAD=0 I QAQSEQ>1 W !!?3,QAQTYPE(1)," macros may only be loaded at the first ",QAQTYPE(0)," selection prompt !! ",*7 R QA:QAQDTIME Q
K DIC,QAQMACRO(QAQTYPE) S DIC(0)="AEMNQZ",DIC("A")="Load" D ASKMAC Q:Y'>0
S (QAQQUIT,QAQNEXT)=0,QAQMLOAD=1
F QAQORDER=0:0 S QAQORDER=$O(^QA(740.1,QAQD0,"FLD",QAQORDER)) Q:QAQORDER'>0!QAQQUIT!QAQNEXT D
. S X=^QA(740.1,QAQD0,"FLD",QAQORDER,0),X("FRTO")=$G(^("FRTO"))
. S X(1)=$P($P(X,"^"),";"),QAQFIELD=$TR(X(1),"&!+#-@'")
. S QA=$G(QAQMENU(+QAQFIELD))
. I (QA="")!((QAQTYPE="S")&(QA'>0)) D Q
.. W !!?3,"Corrupted ",QAQTYPE(0)," macro !! ",*7
.. R QA:QAQDTIME S QAQQUIT=1
.. Q
. S QAQOPTN(QAQTYPE,QAQSEQ,QAQFIELD)=$P(X,"^",2)
. I QAQTYPE="S" D
.. I $P(X,"^",3)'>0 S FR(QAQSEQ)=$P(X("FRTO"),"^"),TO(QAQSEQ)=$P(X("FRTO"),"^",2) Q
.. W !!?3,"Sort by: ",$P(QAQMENU(QAQFIELD),"^",2)
.. S QAQDIR(0)=$P(QAQMENU(QAQFIELD),"^",4,99) D ^QAQAHOC2
.. Q
. S QAQSEQ=QAQSEQ+1
I QAQQUIT!QAQNEXT D Q
. S (QAQQUIT,QAQNEXT,QAQMLOAD)=0,QAQSEQ=1 K QAQCHOSN,QAQOPTN(QAQTYPE)
. I QAQTYPE="S" K QAQBEGIN,QAQEND
. Q
S QAQMACRO(QAQTYPE)=QAQTEMP(QAQTYPE)
Q
INQUIRE ; *** Inquire a sort/print macro
K DIC S DIC(0)="AEMNQZ",DIC("A")="Inquire" D ASKMAC Q:Y'>0
INQ2 ;entry point from DISPMAC
K QAQUNDL S $P(QAQUNDL,"_",81)="",QAQORDER=0
S X=QAQTYPE(1)_" macro: "_QAQTEMP W !!,X,!,$E(QAQUNDL,1,$L(X))
F QAQD1=0:0 S QAQD1=$O(^QA(740.1,QAQD0,"FLD",QAQD1)) Q:QAQD1'>0 D
. S QA=^QA(740.1,QAQD0,"FLD",QAQD1,0),QAQ=$G(^("FRTO"))
. S QAQORDER=QAQORDER+1,X(1)=$P(QA,"^"),QAQFIELD=$P(X(1),";")
. S QAQFIELD=$TR(QAQFIELD,"&!+#-@'") S:QAQFIELD'?1.N QAQFIELD=0
. F QAI=1,2 S X(QAI+1)=$S(QAQTYPE="P":"",$P(QA,"^",3):"Ask User",$P(QAQ,"^",QAI)]"":$P(QAQ,"^",QAI),QAI=1:"Beginning",1:"Ending")
. D PS1^QAQAHOC4:QAQTYPE="S",PP1^QAQAHOC4:QAQTYPE="P"
. Q
R !,QA:(2*QAQDTIME)
Q
DELETE ; *** Delete a sort/print macro
K DIC S DIC(0)="AEMNQZ",DIC("A")="Delete" D ASKMAC Q:Y'>0
DEL W !!?3,"Delete ",QAQTEMP,", are you sure" S %=2 D YN^DICN I '% W !!?5,QAQYESNO G DEL
I %=1 S DIK="^QA(740.1,",DA=QAQD0 D ^DIK
Q
ASKMAC ; *** Prompt user for the name of a sort/print macro
S DIC="^QA(740.1,",DIC("A")=" "_DIC("A")_" "_QAQTYPE(0)_" macro name: ",DLAYGO=740.1
S DIC("S")="I $P(^(0),""^"",2,3)="""_$TR(QAQTYPE,"SP","sp")_"^"_QAQDIC_""""
W ! D ^DIC
I Y>0 S QAQD0=+Y,QAQTEMP=Y(0,0),QAQTEMP(QAQTYPE)=Y
I Y>0 I "^I^D^O^"[QAQSELOP Q
I Y>0 I $P(^QA(740.1,+Y,0),U,4)=QAQCHKSM Q ;S QAQD0=+Y,QAQTEMP=Y(0,0),QAQTEMP(QAQTYPE)=Y Q
I Y>0 I $P(^QA(740.1,+Y,0),U,4)'=QAQCHKSM D
. ;if the menu for the ad hoc report has been altered, the old checksum
. ;values in file 740.1 will not be the same as those calculated at
. ;the beginning of ^QAQAHOC0.
. I $P(^QA(740.1,+Y,0),U,4)']""!($G(QAQMSAVE)=1) Q ;S QAQD0=+Y,QAQTEMP=Y(0,0),QAQTEMP(QAQTYPE)=Y Q
. N DIRUT
. S DIR(0)="YAO"
. S DIR("A")="This macro is not current, would you like to review it? "
. S DIR("B")="YES"
. S DIR("?")="Enter 'Y' if you want to review this macro now."
. D ^DIR I Y=0!($D(DIRUT)) S Y=0 Q
. I Y=1 D DISPMAC
. Q
;I Y'>0 Q
Q
DISPMAC ;if user wants to review macro, display existing macro,
; allow user to say it's okay, then update the checksum value
; (set it to QAQCHKSM) or edit or start over
D INQ2
W !!
S DIR(0)="NAO^1:2"
S DIR("A")="Enter the number of your choice: "
S DIR("A",1)="Review the menu line"_$S("Pp"[QAQTYPE:" and ",1:", ")_"field name"_$S("Pp"[QAQTYPE:".",1:" and sort range.")
S DIR("A",2)=" Enter '1' if the macro displayed still reflects the desired report."
S DIR("A",3)=" Enter '2'if the macro is no longer valid."
K DIR("B")
S DIR("?",1)="Check the display of the macro. If it is still valid enter '1'."
S DIR("?",2)="If the macro is no longer valid enter '2'."
D ^DIR K DIR
I $D(DIRUT) S Y=0 Q
I Y=1 D UPDMAC
I Y=2 D EDITMAC^QAQAHOC5
Q
UPDMAC ;ask user if want to update the macro, if yes, set piece 4 of the
;macro's zero node to QAQCHKSM and check piece 2 of the "FLD" zero node
N QAQEE,QAQFLD
S DIR(0)="YOA"
S DIR("A")="Are you ready to update the "_QAQTEMP_" macro? "
S DIR("B")="YES"
S DIR=("?")="Enter 'Y' if the macro is valid and ready for updating."
D ^DIR K DIR
I $D(DIRUT)!(Y'=1) S Y=0 W !!,"Macro '"_QAQTEMP_"' not updated.",!! R X:5 Q
S $P(^QA(740.1,QAQD0,0),U,4)=QAQCHKSM ;update the checksum
;then update the macro for field, sub-field settings
S QAQEE=0
F S QAQEE=$O(^QA(740.1,QAQD0,"FLD",QAQEE)) Q:QAQEE'>0 D
. S (QAQOUT,QAQPF,QAQPF1,QAQPF2,QAQPFALL,QAQPFEND,QAQPM,QAQPFQUL,QAQPM1,QAQPM2)=""
. S QAQFLD=$P($P(^QA(740.1,QAQD0,"FLD",QAQEE,0),U),";")
. I "'!@#&+-"[$E($G(QAQFLD)) D STRIP^QAQAHOC5
. ;will set several variables to compare the field setings in QAQMENU
. ;to the field settings in the macro, disregarding qualifiers
. ;QAQPF is the piece of the "FLD" node from file 740.1
. ;QAQPFEND is the format part of the field from 740.1 (2nd ";" piece)
. ;QAQPM is the is the field's piece from QAQMENU
. ;QAQPM1 is the 1st "~" piece of the "~" character in the QAQMENU line
. ;QAQPM2 is the 2nd "~ piece from QAQMENU
. ;QAQPF1 is the piece of QAQPF up to any qualifiers
. ;QAQPF2 is the piece of QAQPF after any qualifiers
. S QAQPF=$P($P(^QA(740.1,QAQD0,"FLD",QAQEE,0),U,2),";")
. S QAQPFEND=$P($P(^QA(740.1,QAQD0,"FLD",QAQEE,0),U,2),";",2,999)
. S QAQPM=$P($P(QAQMENU(QAQFLD),U,3),";")
. I $G(QAQPF)']""!($G(QAQPM)']"") S QAQOUT=1 Q
. S QAQPM1=$P(QAQPM,"~"),QAQPM2=$P(QAQPM,"~",2)
. D STRIP2^QAQAHOC5
I $G(QAQOUT)=1 W !!,"Macro incomplete, cannot update." Q
W !!,"Macro '"_QAQTEMP_"' updated.",!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAQAHOC3 8084 printed Dec 13, 2024@02:31:13 Page 2
QAQAHOC3 ;HISC/DAD-AD HOC REPORTS: MACRO MANAGEMENT ;7/12/93 14:35
+1 ;;1.7;QM Integration Module;**1,2,5**;07/25/1995
+2 ;
+3 SET QAQSELOP=$EXTRACT(QAQSELOP,2,999)
if QAQSELOP?1L
SET QAQSELOP=$CHAR($ASCII(QAQSELOP)-32)
+4 IF "^S^L^I^D^O^"'[("^"_QAQSELOP_"^")
SET QAQSELOP=-1
QUIT
+5 WRITE $PIECE($PIECE("^Save^Load^Inquire^Delete^Output^","^"_QAQSELOP,2),"^")," ",$SELECT(QAQSELOP'="O":QAQTYPE(0)_" ",1:""),"macro"
+6 IF $DATA(^QA(740.1,0))[0
WRITE *7,!!?3,"The Ad Hoc Macro file does not exist !!"
SET QAQSELOP=0
READ QA:QAQDTIME
QUIT
+7 if QAQSELOP="S"
DO SETSAVE
if QAQSELOP="L"
DO LOAD
if QAQSELOP="I"
DO INQUIRE
if QAQSELOP="D"
DO DELETE
if QAQSELOP="O"
DO EN1^QAQAHOC4
+8 QUIT
SETSAVE ; *** Set the save macro flag
+1 SET QAQMSAVE=1
WRITE !!?3,"The macro will be saved when you exit the ",QAQTYPE(0)," menu. ",*7
IF QAQSEQ=1
READ QA:QAQDTIME
QUIT
SAVEOUT WRITE !!?3,"OK to exit now"
SET %=1
DO YN^DICN
IF '%
WRITE !!?5,QAQYESNO
GOTO SAVEOUT
+1 if %=1
SET QAQNEXT=1
if %=-1
SET (QAQNEXT,QAQQUIT)=1
+2 QUIT
SAVE ; *** Save a sort/print macro
+1 KILL DIC,QAQMACRO(QAQTYPE)
SET DIC(0)="AELMNQZ"
SET DIC("A")="Save"
DO ASKMAC
if Y'>0
QUIT
+2 IF $PIECE(Y,"^",3)'>0
WRITE *7
Begin DoDot:1
REPLACE WRITE !!?3,QAQTEMP," already exists, OK to replace"
+1 SET %=2
DO YN^DICN
SET QAQREPLC=%
IF '%
WRITE !!?5,QAQYESNO
GOTO REPLACE
+2 if %'=1
QUIT
+3 FOR QAQD1=0:0
SET QAQD1=$ORDER(^QA(740.1,QAQD0,"FLD",QAQD1))
if QAQD1'>0
QUIT
Begin DoDot:2
+4 SET (D0,DA(1))=QAQD0
SET (D1,DA)=QAQD1
SET DIK="^QA(740.1,"_QAQD0_",""FLD"","
+5 DO ^DIK
+6 QUIT
End DoDot:2
+7 QUIT
End DoDot:1
if QAQREPLC=2
GOTO SAVE
if QAQREPLC=-1
QUIT
+8 SET (QAQFLDNO,%)=0
+9 FOR QAQORDER=0:0
SET QAQORDER=$ORDER(QAQOPTN(QAQTYPE,QAQORDER))
if (QAQORDER'>0)!(%=-1)
QUIT
FOR QAQFIELD=0:0
SET QAQFIELD=$ORDER(QAQOPTN(QAQTYPE,QAQORDER,QAQFIELD))
if (QAQFIELD'>0)!(%=-1)
QUIT
Begin DoDot:1
SV IF QAQTYPE="S"
WRITE !!?3,"Ask user BEGINNING/ENDING values for ",$PIECE(QAQMENU(QAQFIELD),"^",2)
SET %=2
DO YN^DICN
if %=-1
QUIT
IF '%
WRITE !!?5,QAQYESNO
GOTO SV
+1 SET X=QAQPREFX(QAQTYPE,QAQORDER)_QAQFIELD_QAQSUFFX(QAQTYPE,QAQORDER)_"^"_QAQOPTN(QAQTYPE,QAQORDER,QAQFIELD)_"^"_$SELECT(QAQTYPE="S":(%=1),1:"")
+2 SET ^QA(740.1,QAQD0,"FLD",QAQORDER,0)=X
SET QAQFLDNO=QAQFLDNO+1
+3 IF QAQTYPE="S"
SET ^QA(740.1,QAQD0,"FLD",QAQORDER,"FRTO")=$SELECT(%=2:QAQBEGIN(QAQORDER)_"^"_QAQEND(QAQORDER),1:"^")
+4 IF '$TEST
KILL ^QA(740.1,QAQD0,"FLD",QAQORDER,"FRTO")
+5 QUIT
End DoDot:1
+6 IF %=-1
SET DIK="^QA(740.1,"
SET DA=QAQD0
DO ^DIK
SET QAQMSAVE=0
WRITE !!?3,"Sort macro ",QAQTEMP," not saved !! ",*7
READ QA:QAQDTIME
QUIT
+7 SET $PIECE(^QA(740.1,QAQD0,0),"^",2,4)=$TRANSLATE(QAQTYPE,"SP","sp")_"^"_QAQDIC_"^"_QAQCHKSM
+8 SET ^QA(740.1,QAQD0,"FLD",0)="^"_$PIECE(^DD(740.1,1,0),"^",2)_"^"_QAQFLDNO_"^"_QAQFLDNO
SET DIK="^QA(740.1,"
SET DA=QAQD0
DO IX1^DIK
+9 SET QAQMACRO(QAQTYPE)=QAQTEMP(QAQTYPE)
+10 QUIT
LOAD ; *** Load a sort/print macro
+1 SET QAQMLOAD=0
IF QAQSEQ>1
WRITE !!?3,QAQTYPE(1)," macros may only be loaded at the first ",QAQTYPE(0)," selection prompt !! ",*7
READ QA:QAQDTIME
QUIT
+2 KILL DIC,QAQMACRO(QAQTYPE)
SET DIC(0)="AEMNQZ"
SET DIC("A")="Load"
DO ASKMAC
if Y'>0
QUIT
+3 SET (QAQQUIT,QAQNEXT)=0
SET QAQMLOAD=1
+4 FOR QAQORDER=0:0
SET QAQORDER=$ORDER(^QA(740.1,QAQD0,"FLD",QAQORDER))
if QAQORDER'>0!QAQQUIT!QAQNEXT
QUIT
Begin DoDot:1
+5 SET X=^QA(740.1,QAQD0,"FLD",QAQORDER,0)
SET X("FRTO")=$GET(^("FRTO"))
+6 SET X(1)=$PIECE($PIECE(X,"^"),";")
SET QAQFIELD=$TRANSLATE(X(1),"&!+#-@'")
+7 SET QA=$GET(QAQMENU(+QAQFIELD))
+8 IF (QA="")!((QAQTYPE="S")&(QA'>0))
Begin DoDot:2
+9 WRITE !!?3,"Corrupted ",QAQTYPE(0)," macro !! ",*7
+10 READ QA:QAQDTIME
SET QAQQUIT=1
+11 QUIT
End DoDot:2
QUIT
+12 SET QAQOPTN(QAQTYPE,QAQSEQ,QAQFIELD)=$PIECE(X,"^",2)
+13 IF QAQTYPE="S"
Begin DoDot:2
+14 IF $PIECE(X,"^",3)'>0
SET FR(QAQSEQ)=$PIECE(X("FRTO"),"^")
SET TO(QAQSEQ)=$PIECE(X("FRTO"),"^",2)
QUIT
+15 WRITE !!?3,"Sort by: ",$PIECE(QAQMENU(QAQFIELD),"^",2)
+16 SET QAQDIR(0)=$PIECE(QAQMENU(QAQFIELD),"^",4,99)
DO ^QAQAHOC2
+17 QUIT
End DoDot:2
+18 SET QAQSEQ=QAQSEQ+1
End DoDot:1
+19 IF QAQQUIT!QAQNEXT
Begin DoDot:1
+20 SET (QAQQUIT,QAQNEXT,QAQMLOAD)=0
SET QAQSEQ=1
KILL QAQCHOSN,QAQOPTN(QAQTYPE)
+21 IF QAQTYPE="S"
KILL QAQBEGIN,QAQEND
+22 QUIT
End DoDot:1
QUIT
+23 SET QAQMACRO(QAQTYPE)=QAQTEMP(QAQTYPE)
+24 QUIT
INQUIRE ; *** Inquire a sort/print macro
+1 KILL DIC
SET DIC(0)="AEMNQZ"
SET DIC("A")="Inquire"
DO ASKMAC
if Y'>0
QUIT
INQ2 ;entry point from DISPMAC
+1 KILL QAQUNDL
SET $PIECE(QAQUNDL,"_",81)=""
SET QAQORDER=0
+2 SET X=QAQTYPE(1)_" macro: "_QAQTEMP
WRITE !!,X,!,$EXTRACT(QAQUNDL,1,$LENGTH(X))
+3 FOR QAQD1=0:0
SET QAQD1=$ORDER(^QA(740.1,QAQD0,"FLD",QAQD1))
if QAQD1'>0
QUIT
Begin DoDot:1
+4 SET QA=^QA(740.1,QAQD0,"FLD",QAQD1,0)
SET QAQ=$GET(^("FRTO"))
+5 SET QAQORDER=QAQORDER+1
SET X(1)=$PIECE(QA,"^")
SET QAQFIELD=$PIECE(X(1),";")
+6 SET QAQFIELD=$TRANSLATE(QAQFIELD,"&!+#-@'")
if QAQFIELD'?1.N
SET QAQFIELD=0
+7 FOR QAI=1,2
SET X(QAI+1)=$SELECT(QAQTYPE="P":"",$PIECE(QA,"^",3):"Ask User",$PIECE(QAQ,"^",QAI)]"":$PIECE(QAQ,"^",QAI),QAI=1:"Beginning",1:"Ending")
+8 if QAQTYPE="S"
DO PS1^QAQAHOC4
if QAQTYPE="P"
DO PP1^QAQAHOC4
+9 QUIT
End DoDot:1
+10 READ !,QA:(2*QAQDTIME)
+11 QUIT
DELETE ; *** Delete a sort/print macro
+1 KILL DIC
SET DIC(0)="AEMNQZ"
SET DIC("A")="Delete"
DO ASKMAC
if Y'>0
QUIT
DEL WRITE !!?3,"Delete ",QAQTEMP,", are you sure"
SET %=2
DO YN^DICN
IF '%
WRITE !!?5,QAQYESNO
GOTO DEL
+1 IF %=1
SET DIK="^QA(740.1,"
SET DA=QAQD0
DO ^DIK
+2 QUIT
ASKMAC ; *** Prompt user for the name of a sort/print macro
+1 SET DIC="^QA(740.1,"
SET DIC("A")=" "_DIC("A")_" "_QAQTYPE(0)_" macro name: "
SET DLAYGO=740.1
+2 SET DIC("S")="I $P(^(0),""^"",2,3)="""_$TRANSLATE(QAQTYPE,"SP","sp")_"^"_QAQDIC_""""
+3 WRITE !
DO ^DIC
+4 IF Y>0
SET QAQD0=+Y
SET QAQTEMP=Y(0,0)
SET QAQTEMP(QAQTYPE)=Y
+5 IF Y>0
IF "^I^D^O^"[QAQSELOP
QUIT
+6 ;S QAQD0=+Y,QAQTEMP=Y(0,0),QAQTEMP(QAQTYPE)=Y Q
IF Y>0
IF $PIECE(^QA(740.1,+Y,0),U,4)=QAQCHKSM
QUIT
+7 IF Y>0
IF $PIECE(^QA(740.1,+Y,0),U,4)'=QAQCHKSM
Begin DoDot:1
+8 ;if the menu for the ad hoc report has been altered, the old checksum
+9 ;values in file 740.1 will not be the same as those calculated at
+10 ;the beginning of ^QAQAHOC0.
+11 ;S QAQD0=+Y,QAQTEMP=Y(0,0),QAQTEMP(QAQTYPE)=Y Q
IF $PIECE(^QA(740.1,+Y,0),U,4)']""!($GET(QAQMSAVE)=1)
QUIT
+12 NEW DIRUT
+13 SET DIR(0)="YAO"
+14 SET DIR("A")="This macro is not current, would you like to review it? "
+15 SET DIR("B")="YES"
+16 SET DIR("?")="Enter 'Y' if you want to review this macro now."
+17 DO ^DIR
IF Y=0!($DATA(DIRUT))
SET Y=0
QUIT
+18 IF Y=1
DO DISPMAC
+19 QUIT
End DoDot:1
+20 ;I Y'>0 Q
+21 QUIT
DISPMAC ;if user wants to review macro, display existing macro,
+1 ; allow user to say it's okay, then update the checksum value
+2 ; (set it to QAQCHKSM) or edit or start over
+3 DO INQ2
+4 WRITE !!
+5 SET DIR(0)="NAO^1:2"
+6 SET DIR("A")="Enter the number of your choice: "
+7 SET DIR("A",1)="Review the menu line"_$SELECT("Pp"[QAQTYPE:" and ",1:", ")_"field name"_$SELECT("Pp"[QAQTYPE:".",1:" and sort range.")
+8 SET DIR("A",2)=" Enter '1' if the macro displayed still reflects the desired report."
+9 SET DIR("A",3)=" Enter '2'if the macro is no longer valid."
+10 KILL DIR("B")
+11 SET DIR("?",1)="Check the display of the macro. If it is still valid enter '1'."
+12 SET DIR("?",2)="If the macro is no longer valid enter '2'."
+13 DO ^DIR
KILL DIR
+14 IF $DATA(DIRUT)
SET Y=0
QUIT
+15 IF Y=1
DO UPDMAC
+16 IF Y=2
DO EDITMAC^QAQAHOC5
+17 QUIT
UPDMAC ;ask user if want to update the macro, if yes, set piece 4 of the
+1 ;macro's zero node to QAQCHKSM and check piece 2 of the "FLD" zero node
+2 NEW QAQEE,QAQFLD
+3 SET DIR(0)="YOA"
+4 SET DIR("A")="Are you ready to update the "_QAQTEMP_" macro? "
+5 SET DIR("B")="YES"
+6 SET DIR=("?")="Enter 'Y' if the macro is valid and ready for updating."
+7 DO ^DIR
KILL DIR
+8 IF $DATA(DIRUT)!(Y'=1)
SET Y=0
WRITE !!,"Macro '"_QAQTEMP_"' not updated.",!!
READ X:5
QUIT
+9 ;update the checksum
SET $PIECE(^QA(740.1,QAQD0,0),U,4)=QAQCHKSM
+10 ;then update the macro for field, sub-field settings
+11 SET QAQEE=0
+12 FOR
SET QAQEE=$ORDER(^QA(740.1,QAQD0,"FLD",QAQEE))
if QAQEE'>0
QUIT
Begin DoDot:1
+13 SET (QAQOUT,QAQPF,QAQPF1,QAQPF2,QAQPFALL,QAQPFEND,QAQPM,QAQPFQUL,QAQPM1,QAQPM2)=""
+14 SET QAQFLD=$PIECE($PIECE(^QA(740.1,QAQD0,"FLD",QAQEE,0),U),";")
+15 IF "'!@#&+-"[$EXTRACT($GET(QAQFLD))
DO STRIP^QAQAHOC5
+16 ;will set several variables to compare the field setings in QAQMENU
+17 ;to the field settings in the macro, disregarding qualifiers
+18 ;QAQPF is the piece of the "FLD" node from file 740.1
+19 ;QAQPFEND is the format part of the field from 740.1 (2nd ";" piece)
+20 ;QAQPM is the is the field's piece from QAQMENU
+21 ;QAQPM1 is the 1st "~" piece of the "~" character in the QAQMENU line
+22 ;QAQPM2 is the 2nd "~ piece from QAQMENU
+23 ;QAQPF1 is the piece of QAQPF up to any qualifiers
+24 ;QAQPF2 is the piece of QAQPF after any qualifiers
+25 SET QAQPF=$PIECE($PIECE(^QA(740.1,QAQD0,"FLD",QAQEE,0),U,2),";")
+26 SET QAQPFEND=$PIECE($PIECE(^QA(740.1,QAQD0,"FLD",QAQEE,0),U,2),";",2,999)
+27 SET QAQPM=$PIECE($PIECE(QAQMENU(QAQFLD),U,3),";")
+28 IF $GET(QAQPF)']""!($GET(QAQPM)']"")
SET QAQOUT=1
QUIT
+29 SET QAQPM1=$PIECE(QAQPM,"~")
SET QAQPM2=$PIECE(QAQPM,"~",2)
+30 DO STRIP2^QAQAHOC5
End DoDot:1
+31 IF $GET(QAQOUT)=1
WRITE !!,"Macro incomplete, cannot update."
QUIT
+32 WRITE !!,"Macro '"_QAQTEMP_"' updated.",!!
+33 QUIT
