Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: QAQAHOC3

QAQAHOC3.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  S QAQSELOP=$E(QAQSELOP,2,999) S:QAQSELOP?1L QAQSELOP=$C($A(QAQSELOP)-32)
  1.  I "^S^L^I^D^O^"'[("^"_QAQSELOP_"^") S QAQSELOP=-1 Q
  1.  W $P($P("^Save^Load^Inquire^Delete^Output^","^"_QAQSELOP,2),"^")," ",$S(QAQSELOP'="O":QAQTYPE(0)_" ",1:""),"macro"
  1.  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
  1.  D SETSAVE:QAQSELOP="S",LOAD:QAQSELOP="L",INQUIRE:QAQSELOP="I",DELETE:QAQSELOP="D",EN1^QAQAHOC4:QAQSELOP="O"
  1.  Q
  1. SETSAVE ; *** Set the save macro flag
  1.  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
  1. SAVEOUT W !!?3,"OK to exit now" S %=1 D YN^DICN I '% W !!?5,QAQYESNO G SAVEOUT
  1.  S:%=1 QAQNEXT=1 S:%=-1 (QAQNEXT,QAQQUIT)=1
  1.  Q
  1. SAVE ; *** Save a sort/print macro
  1.  K DIC,QAQMACRO(QAQTYPE) S DIC(0)="AELMNQZ",DIC("A")="Save" D ASKMAC Q:Y'>0
  1.  I $P(Y,"^",3)'>0 W *7 D  G SAVE:QAQREPLC=2 Q:QAQREPLC=-1
  1. REPLACE . W !!?3,QAQTEMP," already exists, OK to replace"
  1.  . S %=2 D YN^DICN S QAQREPLC=%  I '% W !!?5,QAQYESNO G REPLACE
  1.  . Q:%'=1
  1.  . F QAQD1=0:0 S QAQD1=$O(^QA(740.1,QAQD0,"FLD",QAQD1)) Q:QAQD1'>0  D
  1.  .. S (D0,DA(1))=QAQD0,(D1,DA)=QAQD1,DIK="^QA(740.1,"_QAQD0_",""FLD"","
  1.  .. D ^DIK
  1.  .. Q
  1.  . Q
  1.  S (QAQFLDNO,%)=0
  1.  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
  1. 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
  1.  . S X=QAQPREFX(QAQTYPE,QAQORDER)_QAQFIELD_QAQSUFFX(QAQTYPE,QAQORDER)_"^"_QAQOPTN(QAQTYPE,QAQORDER,QAQFIELD)_"^"_$S(QAQTYPE="S":(%=1),1:"")
  1.  . S ^QA(740.1,QAQD0,"FLD",QAQORDER,0)=X,QAQFLDNO=QAQFLDNO+1
  1.  . I QAQTYPE="S" S ^QA(740.1,QAQD0,"FLD",QAQORDER,"FRTO")=$S(%=2:QAQBEGIN(QAQORDER)_"^"_QAQEND(QAQORDER),1:"^")
  1.  . E  K ^QA(740.1,QAQD0,"FLD",QAQORDER,"FRTO")
  1.  . Q
  1.  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
  1.  S $P(^QA(740.1,QAQD0,0),"^",2,4)=$TR(QAQTYPE,"SP","sp")_"^"_QAQDIC_"^"_QAQCHKSM
  1.  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
  1.  S QAQMACRO(QAQTYPE)=QAQTEMP(QAQTYPE)
  1.  Q
  1. LOAD ; *** Load a sort/print macro
  1.  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
  1.  K DIC,QAQMACRO(QAQTYPE) S DIC(0)="AEMNQZ",DIC("A")="Load" D ASKMAC Q:Y'>0
  1.  S (QAQQUIT,QAQNEXT)=0,QAQMLOAD=1
  1.  F QAQORDER=0:0 S QAQORDER=$O(^QA(740.1,QAQD0,"FLD",QAQORDER)) Q:QAQORDER'>0!QAQQUIT!QAQNEXT  D
  1.  . S X=^QA(740.1,QAQD0,"FLD",QAQORDER,0),X("FRTO")=$G(^("FRTO"))
  1.  . S X(1)=$P($P(X,"^"),";"),QAQFIELD=$TR(X(1),"&!+#-@'")
  1.  . S QA=$G(QAQMENU(+QAQFIELD))
  1.  . I (QA="")!((QAQTYPE="S")&(QA'>0)) D  Q
  1.  .. W !!?3,"Corrupted ",QAQTYPE(0)," macro !! ",*7
  1.  .. R QA:QAQDTIME S QAQQUIT=1
  1.  .. Q
  1.  . S QAQOPTN(QAQTYPE,QAQSEQ,QAQFIELD)=$P(X,"^",2)
  1.  . I QAQTYPE="S" D
  1.  .. I $P(X,"^",3)'>0 S FR(QAQSEQ)=$P(X("FRTO"),"^"),TO(QAQSEQ)=$P(X("FRTO"),"^",2) Q
  1.  .. W !!?3,"Sort by: ",$P(QAQMENU(QAQFIELD),"^",2)
  1.  .. S QAQDIR(0)=$P(QAQMENU(QAQFIELD),"^",4,99) D ^QAQAHOC2
  1.  .. Q
  1.  . S QAQSEQ=QAQSEQ+1
  1.  I QAQQUIT!QAQNEXT D  Q
  1.  . S (QAQQUIT,QAQNEXT,QAQMLOAD)=0,QAQSEQ=1 K QAQCHOSN,QAQOPTN(QAQTYPE)
  1.  . I QAQTYPE="S" K QAQBEGIN,QAQEND
  1.  . Q
  1.  S QAQMACRO(QAQTYPE)=QAQTEMP(QAQTYPE)
  1.  Q
  1. INQUIRE ; *** Inquire a sort/print macro
  1.  K DIC S DIC(0)="AEMNQZ",DIC("A")="Inquire" D ASKMAC Q:Y'>0
  1. INQ2 ;entry point from DISPMAC
  1.  K QAQUNDL S $P(QAQUNDL,"_",81)="",QAQORDER=0
  1.  S X=QAQTYPE(1)_" macro: "_QAQTEMP W !!,X,!,$E(QAQUNDL,1,$L(X))
  1.  F QAQD1=0:0 S QAQD1=$O(^QA(740.1,QAQD0,"FLD",QAQD1)) Q:QAQD1'>0  D
  1.  . S QA=^QA(740.1,QAQD0,"FLD",QAQD1,0),QAQ=$G(^("FRTO"))
  1.  . S QAQORDER=QAQORDER+1,X(1)=$P(QA,"^"),QAQFIELD=$P(X(1),";")
  1.  . S QAQFIELD=$TR(QAQFIELD,"&!+#-@'") S:QAQFIELD'?1.N QAQFIELD=0
  1.  . 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")
  1.  . D PS1^QAQAHOC4:QAQTYPE="S",PP1^QAQAHOC4:QAQTYPE="P"
  1.  . Q
  1.  R !,QA:(2*QAQDTIME)
  1.  Q
  1. DELETE ; *** Delete a sort/print macro
  1.  K DIC S DIC(0)="AEMNQZ",DIC("A")="Delete" D ASKMAC Q:Y'>0
  1. DEL W !!?3,"Delete ",QAQTEMP,", are you sure" S %=2 D YN^DICN I '% W !!?5,QAQYESNO G DEL
  1.  I %=1 S DIK="^QA(740.1,",DA=QAQD0 D ^DIK
  1.  Q
  1. ASKMAC ; *** Prompt user for the name of a sort/print macro
  1.  S DIC="^QA(740.1,",DIC("A")="   "_DIC("A")_" "_QAQTYPE(0)_" macro name: ",DLAYGO=740.1
  1.  S DIC("S")="I $P(^(0),""^"",2,3)="""_$TR(QAQTYPE,"SP","sp")_"^"_QAQDIC_""""
  1.  W ! D ^DIC
  1.  I Y>0 S QAQD0=+Y,QAQTEMP=Y(0,0),QAQTEMP(QAQTYPE)=Y
  1.  I Y>0 I "^I^D^O^"[QAQSELOP Q
  1.  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
  1.  I Y>0 I $P(^QA(740.1,+Y,0),U,4)'=QAQCHKSM D
  1.  . ;if the menu for the ad hoc report has been altered, the old checksum
  1.  . ;values in file 740.1 will not be the same as those calculated at
  1.  . ;the beginning of ^QAQAHOC0.
  1.  . I $P(^QA(740.1,+Y,0),U,4)']""!($G(QAQMSAVE)=1) Q  ;S QAQD0=+Y,QAQTEMP=Y(0,0),QAQTEMP(QAQTYPE)=Y Q
  1.  . N DIRUT
  1.  . S DIR(0)="YAO"
  1.  . S DIR("A")="This macro is not current, would you like to review it? "
  1.  . S DIR("B")="YES"
  1.  . S DIR("?")="Enter 'Y' if you want to review this macro now."
  1.  . D ^DIR I Y=0!($D(DIRUT)) S Y=0 Q
  1.  . I Y=1 D DISPMAC
  1.  . Q
  1.  ;I Y'>0 Q
  1.  Q
  1. DISPMAC ;if user wants to review macro, display existing macro,
  1.  ; allow user to say it's okay, then update the checksum value
  1.  ; (set it to QAQCHKSM) or edit or start over
  1.  D INQ2
  1.  W !!
  1.  S DIR(0)="NAO^1:2"
  1.  S DIR("A")="Enter the number of your choice: "
  1.  S DIR("A",1)="Review the menu line"_$S("Pp"[QAQTYPE:" and ",1:", ")_"field name"_$S("Pp"[QAQTYPE:".",1:" and sort range.")
  1.  S DIR("A",2)="   Enter '1' if the macro displayed still reflects the desired report."
  1.  S DIR("A",3)="   Enter '2'if the macro is no longer valid."
  1.  K DIR("B")
  1.  S DIR("?",1)="Check the display of the macro.  If it is still valid enter '1'."
  1.  S DIR("?",2)="If the macro is no longer valid enter '2'."
  1.  D ^DIR K DIR
  1.  I $D(DIRUT) S Y=0 Q
  1.  I Y=1 D UPDMAC
  1.  I Y=2 D EDITMAC^QAQAHOC5
  1.  Q
  1. 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
  1.  N QAQEE,QAQFLD
  1.  S DIR(0)="YOA"
  1.  S DIR("A")="Are you ready to update the "_QAQTEMP_" macro? "
  1.  S DIR("B")="YES"
  1.  S DIR=("?")="Enter 'Y' if the macro is valid and ready for updating."
  1.  D ^DIR K DIR
  1.  I $D(DIRUT)!(Y'=1) S Y=0 W !!,"Macro '"_QAQTEMP_"' not updated.",!! R X:5 Q
  1.  S $P(^QA(740.1,QAQD0,0),U,4)=QAQCHKSM ;update the checksum
  1.  ;then update the macro for field, sub-field settings
  1.  S QAQEE=0
  1.  F  S QAQEE=$O(^QA(740.1,QAQD0,"FLD",QAQEE)) Q:QAQEE'>0  D
  1.  . S (QAQOUT,QAQPF,QAQPF1,QAQPF2,QAQPFALL,QAQPFEND,QAQPM,QAQPFQUL,QAQPM1,QAQPM2)=""
  1.  . S QAQFLD=$P($P(^QA(740.1,QAQD0,"FLD",QAQEE,0),U),";")
  1.  . I "'!@#&+-"[$E($G(QAQFLD)) D STRIP^QAQAHOC5
  1.  . ;will set several variables to compare the field setings in QAQMENU
  1.  . ;to the field settings in the macro, disregarding qualifiers
  1.  . ;QAQPF is the piece of the "FLD" node from file 740.1
  1.  . ;QAQPFEND is the format part of the field from 740.1 (2nd ";" piece)
  1.  . ;QAQPM is the is the field's piece from QAQMENU
  1.  . ;QAQPM1 is the 1st "~" piece of the "~" character in the QAQMENU line
  1.  . ;QAQPM2 is the 2nd "~ piece from QAQMENU
  1.  . ;QAQPF1 is the piece of QAQPF up to any qualifiers
  1.  . ;QAQPF2 is the piece of QAQPF after any qualifiers
  1.  . S QAQPF=$P($P(^QA(740.1,QAQD0,"FLD",QAQEE,0),U,2),";")
  1.  . S QAQPFEND=$P($P(^QA(740.1,QAQD0,"FLD",QAQEE,0),U,2),";",2,999)
  1.  . S QAQPM=$P($P(QAQMENU(QAQFLD),U,3),";")
  1.  . I $G(QAQPF)']""!($G(QAQPM)']"") S QAQOUT=1 Q
  1.  . S QAQPM1=$P(QAQPM,"~"),QAQPM2=$P(QAQPM,"~",2)
  1.  . D STRIP2^QAQAHOC5
  1.  I $G(QAQOUT)=1 W !!,"Macro incomplete, cannot update."  Q
  1.  W !!,"Macro '"_QAQTEMP_"' updated.",!!
  1.  Q