QAQAHOC0 ;HISC/DAD-AD HOC REPORTS: MAIN DRIVER ;7/12/95 14:53
;;1.7;QM Integration Module;**1**;07/25/1995
;
;Required / Optional Variables
;
; QAQDIC = File NUMBER of the file to print from.
; QAQMRTN = Entry point to setup the QAQMENU array (Format TAG^ROUTINE)
; QAQORTN = Entry point to set up other FileMan EN1^DIP variables, i.e.
; DCOPIES, DHD, DHIT, DIOBEG, DIOEND, DIS(), IOP, PG optional
; QAQMHDR = Text to be used as the header at the top of the sort/print
; menu screens. Header appears as === QAQMHDR Ad Hoc Report
; Generator ===. Set QAQMHDR = @ to suppress the header.
; Maximum of 45 characters.
;
;Menu Array Format (Set up by D @QAQMRTN)
;
; QAQMENU() = Sort ^ Menu text ^ ~Field # ^ DIR(0)
; Sort = 1 - Allow sorting, 0 - Don't allow sorting.
; Menu text = Menu text as it will appear to the user (Max 30 char).
; ~Field # = Any valid EN1^DIP BY/FLDS string. The ~ is replaced by
; the sort/print prefixes entered by the user or null.
; Any ;"TEXT" appended to the BY/FLDS string should be
; in the last ';' piece of the string.
; DIR(0) = The DIR(0) string used when the user is prompted for a
; from/to range on the sort. DIR(0) should have a third
; '^' piece (input transform) that always returns the
; external form of the data or -1 in the variable Y.
;
G:$S($D(QAQDIC)[0:1,QAQDIC'>0:1,$D(^DIC(QAQDIC,0))[0:1,$D(QAQMRTN)[0:1,QAQMRTN="":1,1:0) EXIT I $D(QAQORTN)#2,QAQORTN="" G EXIT
D XIT,HOME^%ZIS,@QAQMRTN K QAQMENU(0)
S (QAQMMAX,QAQCHKSM,QAQSORT)=0 F QA=0:0 S QA=$O(QAQMENU(QA)) Q:QA'>0 D
. S QAQMMAX=QAQMMAX+1,QAQCHKSM(0)=0,X=QAQMENU(QA) S:X QAQSORT=QAQSORT+1
. F QAI=1:1:$L(X) S QAQCHKSM(0)=$A(X,QAI)*QAI+QAQCHKSM(0)
. S QAQCHKSM=QAQCHKSM(0)*QA+QAQCHKSM
. Q
G:(QAQMMAX'>0)!(QAQSORT'>0) EXIT
S QAQBLURB="Enter numeric 1 to "_QAQMMAX_", <RETURN> to end, ^ to exit"
S QAQYESNO="Please answer Y(es) or N(o).",QAQDTIME=10,(BY,FLDS)=""
S QAQMAXOP("S")=4,QAQMAXOP("P")=7,(QAQNUMOP("S"),QAQNUMOP("P"),QAQQUIT,QAQNEXT)=0
;
SORT S QAQTYPE="S",QAQTYPE(0)="sort",QAQTYPE(1)="Sort",(QAQMLOAD,QAQMOUTP,QAQMSAVE)=0 K QAQCHOSN F QAQSEQ=1:1 D ENASK^QAQAHOC1 Q:QAQNEXT
S QAQNUMOP("S")=QAQSEQ-1 G EXIT:QAQQUIT,PRNT:QAQMLOAD D:QAQMSAVE SAVE^QAQAHOC3
PRNT D:QAQMOUTP EN2^QAQAHOC4
S QAQTYPE="P",QAQTYPE(0)="print",QAQTYPE(1)="Print",(QAQMLOAD,QAQMOUTP,QAQMSAVE)=0 K QAQCHOSN F QAQSEQ=1:1 D ENASK^QAQAHOC1 Q:QAQNEXT
S QAQNUMOP("P")=QAQSEQ-1 G EXIT:QAQQUIT,OTHER:QAQMLOAD D:QAQMSAVE SAVE^QAQAHOC3
OTHER ; *** Execute OTHER entry point in the Ad Hoc interface routine
D:QAQMOUTP EN2^QAQAHOC4
K DHD,PG,DHIT,DIOEND,DIOBEG,DCOPIES,IOP,DIS
I $D(QAQORTN)#2 S QAQQUIT=0 D @QAQORTN G:QAQQUIT EXIT
DHD ; *** Prompt user for report header
G:$D(DHD)#2 BYFLDS
K DIR S DIR(0)="FAO^0:60^D DHDCHK^QAQAHOC0"
S DIR("A",1)=" Enter special report header, if desired (maximum of 60 characters).",DIR("A")=" ",DIR("?")="^D EN^QAQAHOCH(""H5"")"
W ! D ^DIR G:$D(DIROUT)!$D(DTOUT)!$D(DUOUT) EXIT
K DHD S:Y]"" DHD=Y
BYFLDS ; *** Process the BY and FLDS strings
K QAQCHOSN
F QA=1:1:QAQNUMOP("P") S QAI=$O(QAQOPTN("P",QA,"")) Q:QAI="" D
. S @$S(QA=1:"FLDS",1:"FLDS("_(QA-1)_")")=QAQOPTN("P",QA,QAI)
. S QAQCHOSN(QAI)=""
. Q
F QA=1:1:QAQNUMOP("S") S QAI=$O(QAQOPTN("S",QA,"")) Q:QAI="" D
. S X=QAQOPTN("S",QA,QAI),QAQSHD=$P(X,";",$L(X,";")),Y=$L(QAQSHD)
. I QAQSHD["""" D
.. S X=$P(X,";",1,$L(X,";")-1)
.. S QAQSHD=";"_$E(QAQSHD,1,Y-1)_$S($L(QAQSHD)>2:": """,1:"""")
.. S X=X_$S($D(QAQCHOSN(QAI))[0:QAQSHD,X[":,":"",X[":":QAQSHD,1:"")
.. Q
. I $L(BY)+$L(X)+1>255 D Q
.. W !!?3,"Sort too big !!"
.. W !?3,"Skipping sort field number ",QAI,", "
.. W $P(QAQMENU(QAI),"^",2),"."
.. Q
. S BY=BY_X_","
. Q
K DIC S DIC=QAQDIC,L=0,BY=$$COMMA(BY)
W ! D XIT,EN1^DIP
EXIT ; *** Exit the Ad Hoc Reoprt Generator
K BY,DCOPIES,DHD,DHIT,DIC,DIOBEG,DIOEND,DIS,FLDS,FR,IOP,L,PG,TO,QAQDIC,QAQFOUND,QAQMHDR,QAQMMAX,QAQMRTN,QAQORTN
XIT K %,%DT,%ZIS,D0,D1,DA,DIK,DIR,DIROUT,DIRUT,DLAYGO,DTOUT,DUOUT,POP,QA,QAI,QAQ,QAQAGIN,QAQBEGIN,QAQBLURB,QAQCHKSM,QAQCHOSN,QAQD0,QAQD1,QAQDIR,QAQDTIME,QAQEND,QAQEXIT,QAQFIELD,QAQFLDNO,QAQLIST,QAQLST,QAQMACRO,QAQMAXOP,QAQMENU
K QAQMLOAD,QAQMOUTP,QAQMSAVE,QAQNEXT,QAQNONE,QAQNUMOP,QAQOK,QAQOPTN,QAQORDER,QAQPREFX,QAQQUIT,QAQREPLC,QAQSELOP,QAQSEQ,QAQSHD,QAQSORT,QAQSUFFX,QAQTAB,QAQTEMP,QAQTYPE,QAQUNDL,QAQYESNO,X,Y,ZTDESC,ZTRTN,ZTSAVE,ZTSK
Q
COMMA(X) ; *** Remove extra commas from X
F QA=$L(X):-1 Q:$E(X,QA)'=","
Q $E(X,1,QA)
DHDCHK ; *** Check DHD for MUMPS code
Q:X'?1"W ".E Q:$G(DUZ(0))["@" N QA
F QA=1:2 Q:$P(X,"""",QA,999)="" I $P($E(X,3,999),"""",QA)[" " K X Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAQAHOC0 4778 printed Oct 16, 2024@18:31:54 Page 2
QAQAHOC0 ;HISC/DAD-AD HOC REPORTS: MAIN DRIVER ;7/12/95 14:53
+1 ;;1.7;QM Integration Module;**1**;07/25/1995
+2 ;
+3 ;Required / Optional Variables
+4 ;
+5 ; QAQDIC = File NUMBER of the file to print from.
+6 ; QAQMRTN = Entry point to setup the QAQMENU array (Format TAG^ROUTINE)
+7 ; QAQORTN = Entry point to set up other FileMan EN1^DIP variables, i.e.
+8 ; DCOPIES, DHD, DHIT, DIOBEG, DIOEND, DIS(), IOP, PG optional
+9 ; QAQMHDR = Text to be used as the header at the top of the sort/print
+10 ; menu screens. Header appears as === QAQMHDR Ad Hoc Report
+11 ; Generator ===. Set QAQMHDR = @ to suppress the header.
+12 ; Maximum of 45 characters.
+13 ;
+14 ;Menu Array Format (Set up by D @QAQMRTN)
+15 ;
+16 ; QAQMENU() = Sort ^ Menu text ^ ~Field # ^ DIR(0)
+17 ; Sort = 1 - Allow sorting, 0 - Don't allow sorting.
+18 ; Menu text = Menu text as it will appear to the user (Max 30 char).
+19 ; ~Field # = Any valid EN1^DIP BY/FLDS string. The ~ is replaced by
+20 ; the sort/print prefixes entered by the user or null.
+21 ; Any ;"TEXT" appended to the BY/FLDS string should be
+22 ; in the last ';' piece of the string.
+23 ; DIR(0) = The DIR(0) string used when the user is prompted for a
+24 ; from/to range on the sort. DIR(0) should have a third
+25 ; '^' piece (input transform) that always returns the
+26 ; external form of the data or -1 in the variable Y.
+27 ;
+28 if $SELECT($DATA(QAQDIC)[0
GOTO EXIT
IF $DATA(QAQORTN)#2
IF QAQORTN=""
GOTO EXIT
+29 DO XIT
DO HOME^%ZIS
DO @QAQMRTN
KILL QAQMENU(0)
+30 SET (QAQMMAX,QAQCHKSM,QAQSORT)=0
FOR QA=0:0
SET QA=$ORDER(QAQMENU(QA))
if QA'>0
QUIT
Begin DoDot:1
+31 SET QAQMMAX=QAQMMAX+1
SET QAQCHKSM(0)=0
SET X=QAQMENU(QA)
if X
SET QAQSORT=QAQSORT+1
+32 FOR QAI=1:1:$LENGTH(X)
SET QAQCHKSM(0)=$ASCII(X,QAI)*QAI+QAQCHKSM(0)
+33 SET QAQCHKSM=QAQCHKSM(0)*QA+QAQCHKSM
+34 QUIT
End DoDot:1
+35 if (QAQMMAX'>0)!(QAQSORT'>0)
GOTO EXIT
+36 SET QAQBLURB="Enter numeric 1 to "_QAQMMAX_", <RETURN> to end, ^ to exit"
+37 SET QAQYESNO="Please answer Y(es) or N(o)."
SET QAQDTIME=10
SET (BY,FLDS)=""
+38 SET QAQMAXOP("S")=4
SET QAQMAXOP("P")=7
SET (QAQNUMOP("S"),QAQNUMOP("P"),QAQQUIT,QAQNEXT)=0
+39 ;
SORT SET QAQTYPE="S"
SET QAQTYPE(0)="sort"
SET QAQTYPE(1)="Sort"
SET (QAQMLOAD,QAQMOUTP,QAQMSAVE)=0
KILL QAQCHOSN
FOR QAQSEQ=1:1
DO ENASK^QAQAHOC1
if QAQNEXT
QUIT
+1 SET QAQNUMOP("S")=QAQSEQ-1
if QAQQUIT
GOTO EXIT
if QAQMLOAD
GOTO PRNT
if QAQMSAVE
DO SAVE^QAQAHOC3
PRNT if QAQMOUTP
DO EN2^QAQAHOC4
+1 SET QAQTYPE="P"
SET QAQTYPE(0)="print"
SET QAQTYPE(1)="Print"
SET (QAQMLOAD,QAQMOUTP,QAQMSAVE)=0
KILL QAQCHOSN
FOR QAQSEQ=1:1
DO ENASK^QAQAHOC1
if QAQNEXT
QUIT
+2 SET QAQNUMOP("P")=QAQSEQ-1
if QAQQUIT
GOTO EXIT
if QAQMLOAD
GOTO OTHER
if QAQMSAVE
DO SAVE^QAQAHOC3
OTHER ; *** Execute OTHER entry point in the Ad Hoc interface routine
+1 if QAQMOUTP
DO EN2^QAQAHOC4
+2 KILL DHD,PG,DHIT,DIOEND,DIOBEG,DCOPIES,IOP,DIS
+3 IF $DATA(QAQORTN)#2
SET QAQQUIT=0
DO @QAQORTN
if QAQQUIT
GOTO EXIT
DHD ; *** Prompt user for report header
+1 if $DATA(DHD)#2
GOTO BYFLDS
+2 KILL DIR
SET DIR(0)="FAO^0:60^D DHDCHK^QAQAHOC0"
+3 SET DIR("A",1)=" Enter special report header, if desired (maximum of 60 characters)."
SET DIR("A")=" "
SET DIR("?")="^D EN^QAQAHOCH(""H5"")"
+4 WRITE !
DO ^DIR
if $DATA(DIROUT)!$DATA(DTOUT)!$DATA(DUOUT)
GOTO EXIT
+5 KILL DHD
if Y]""
SET DHD=Y
BYFLDS ; *** Process the BY and FLDS strings
+1 KILL QAQCHOSN
+2 FOR QA=1:1:QAQNUMOP("P")
SET QAI=$ORDER(QAQOPTN("P",QA,""))
if QAI=""
QUIT
Begin DoDot:1
+3 SET @$SELECT(QA=1:"FLDS",1:"FLDS("_(QA-1)_")")=QAQOPTN("P",QA,QAI)
+4 SET QAQCHOSN(QAI)=""
+5 QUIT
End DoDot:1
+6 FOR QA=1:1:QAQNUMOP("S")
SET QAI=$ORDER(QAQOPTN("S",QA,""))
if QAI=""
QUIT
Begin DoDot:1
+7 SET X=QAQOPTN("S",QA,QAI)
SET QAQSHD=$PIECE(X,";",$LENGTH(X,";"))
SET Y=$LENGTH(QAQSHD)
+8 IF QAQSHD[""""
Begin DoDot:2
+9 SET X=$PIECE(X,";",1,$LENGTH(X,";")-1)
+10 SET QAQSHD=";"_$EXTRACT(QAQSHD,1,Y-1)_$SELECT($LENGTH(QAQSHD)>2:": """,1:"""")
+11 SET X=X_$SELECT($DATA(QAQCHOSN(QAI))[0:QAQSHD,X[":,":"",X[":":QAQSHD,1:"")
+12 QUIT
End DoDot:2
+13 IF $LENGTH(BY)+$LENGTH(X)+1>255
Begin DoDot:2
+14 WRITE !!?3,"Sort too big !!"
+15 WRITE !?3,"Skipping sort field number ",QAI,", "
+16 WRITE $PIECE(QAQMENU(QAI),"^",2),"."
+17 QUIT
End DoDot:2
QUIT
+18 SET BY=BY_X_","
+19 QUIT
End DoDot:1
+20 KILL DIC
SET DIC=QAQDIC
SET L=0
SET BY=$$COMMA(BY)
+21 WRITE !
DO XIT
DO EN1^DIP
EXIT ; *** Exit the Ad Hoc Reoprt Generator
+1 KILL BY,DCOPIES,DHD,DHIT,DIC,DIOBEG,DIOEND,DIS,FLDS,FR,IOP,L,PG,TO,QAQDIC,QAQFOUND,QAQMHDR,QAQMMAX,QAQMRTN,QAQORTN
XIT KILL %,%DT,%ZIS,D0,D1,DA,DIK,DIR,DIROUT,DIRUT,DLAYGO,DTOUT,DUOUT,POP,QA,QAI,QAQ,QAQAGIN,QAQBEGIN,QAQBLURB,QAQCHKSM,QAQCHOSN,QAQD0,QAQD1,QAQDIR,QAQDTIME,QAQEND,QAQEXIT,QAQFIELD,QAQFLDNO,QAQLIST,QAQLST,QAQMACRO,QAQMAXOP,QAQMENU
+1 KILL QAQMLOAD,QAQMOUTP,QAQMSAVE,QAQNEXT,QAQNONE,QAQNUMOP,QAQOK,QAQOPTN,QAQORDER,QAQPREFX,QAQQUIT,QAQREPLC,QAQSELOP,QAQSEQ,QAQSHD,QAQSORT,QAQSUFFX,QAQTAB,QAQTEMP,QAQTYPE,QAQUNDL,QAQYESNO,X,Y,ZTDESC,ZTRTN,ZTSAVE,ZTSK
+2 QUIT
COMMA(X) ; *** Remove extra commas from X
+1 FOR QA=$LENGTH(X):-1
if $EXTRACT(X,QA)'=","
QUIT
+2 QUIT $EXTRACT(X,1,QA)
DHDCHK ; *** Check DHD for MUMPS code
+1 if X'?1"W ".E
QUIT
if $GET(DUZ(0))["@"
QUIT
NEW QA
+2 FOR QA=1:2
if $PIECE(X,"""",QA,999)=""
QUIT
IF $PIECE($EXTRACT(X,3,999),"""",QA)[" "
KILL X
QUIT
+3 QUIT
