- 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 Jan 18, 2025@03:32:20 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