- QAQAHOCY ;HISC/DAD-AD HOC REPORTS: INTERFACE COMPILER ;7/12/95 14:57
- ;;1.7;QM Integration Module;;07/25/1995
- ;
- S (QAQMMAX,QAQSORT)=0,QAQLEVEL=1,QAQFILE(QAQLEVEL)=QAQFILE
- FLD ; *** Process the sort/print fields
- W !!,"Choose a field for menu item number ",QAQMMAX+1,", <RETURN> to end, ^ to exit."
- W !,"Select ",$S(QAQLEVEL=1:"",1:$P(QAQFILE(QAQLEVEL-1),"^",3)_" SUB-"),"FIELD: " R X:DTIME S:'$T X="^" S QAQQUIT=$S($E(X)="^":1,1:0)
- I X="?",QAQMMAX D LIST G:QAQQUIT FLD W !
- K DIC S DIC="^DD("_+QAQFILE(QAQLEVEL)_",",DIC(0)="EMNQZ",DIC("W")="S QA=+$P(^(0),""^"",2) W:QA "" "",$S($P(^DD(QA,.01,0),""^"",2)[""W"":""(word-processing)"",1:""(multiple)"")" D ^DIC
- I Y'>0 S:X="" QAQLEVEL=QAQLEVEL-1 G EXIT:'QAQLEVEL!QAQQUIT,FLD
- S QAQDD=Y(0),$P(QAQFILE(QAQLEVEL),"^",2,3)=+Y_"^"_$P(QAQDD,"^"),QAQWP=0 ; *** QAQFILE(Level#) = Dict # ^ Fld # ^ Fld Name
- I +$P(QAQDD,"^",2) S QAQWP=($P(^DD(+$P(QAQDD,"^",2),.01,0),"^",2)["W") I 'QAQWP S QAQLEVEL=QAQLEVEL+1,QAQFILE(QAQLEVEL)=+$P(QAQDD,"^",2) G FLD
- I $D(QAQCHOSN(QAQFILE(QAQLEVEL)))#2 W !!?5,"*** You have already chosen that field !! ***",*7 G FLD
- F QA=1:1:4 S QAQTEXT(QA)=""
- NAME ; *** Prompt user for the external field name
- K DIR S DIR(0)="FOA^2:30^K:X[""^"" X",DIR("A")="Menu text the user should see: ",DIR("B")=$$CASE($P(QAQDD,"^")),DIR("?")="^D EN^QAQAHOCH(""H7"")"
- D ^DIR G:$D(DIRUT) FLD S QAQTEXT(2)=Y
- SORT ; *** Allow sorting on this field (Y/N)
- G:QAQWP SETLINE ; *** Don't ask sort questions for WP fields
- S X=$P(QAQDD,"^",2),%=$S($P(QAQFILE(QAQLEVEL),"^",2)=.01:1,X["F":2,X["K":2,X["V":2,1:1)
- W !,"Want to allow sorting by ",QAQTEXT(2) D YN^DICN G:%=-1 FLD S QAQTEXT(1)=(%=1),QAQSORT=QAQSORT+QAQTEXT(1) I '% W !!?5,QAQYESNO,! G SORT
- DIR ; *** Set up DIR(0) for sort from/to prompts
- S X=$P(QAQDD,"^",2)
- G NUMERIC:X["N",POINTER:X["P",SET:X["S",DATE:X["D",TEXT
- DATE S QAQTEXT(4)="DAO^::AETS^D DATE^QAQAHOC2" G SETLINE
- NUMERIC S QAQTEXT(4)="NAO^-999999999:999999999:9^" G SETLINE
- POINTER S QA=$P(QAQDD,"^",2),QA=$TR(QA,$TR(QA,".0123456789"))
- S QAQTEXT(4)="PAO^"_QA_":AEMNQZ^D POINTER^QAQAHOC2" G SETLINE
- SET S QAQTEXT(4)="SAO^"_$P(QAQDD,"^",3)_"^D SET^QAQAHOC2" G SETLINE
- TEXT S QAQTEXT(4)="FAO^1:60^"
- SETLINE ; *** Save menu $TEXT line in ^TMP
- F QA=1:1:QAQLEVEL S QAQTEXT(3)=QAQTEXT(3)_$S(QA=QAQLEVEL:"~",1:"")_$P(QAQFILE(QA),"^",2)_$S(QA'=QAQLEVEL:",",1:$S(QAQTEXT(2)'=$P(QAQFILE(QA),"^",3):";"""_$TR(QAQTEXT(2),",;^~"," ")_"""",1:""))
- S Y=7+$L(QAQTEXT(2))+$L(QAQTEXT(3))+$L(QAQTEXT(4))-245 I Y>0 W !!?5,"*** This line is ",Y," character",$S(Y>1:"s",1:"")," too long, maximum is 245 !! ***",*7 G FLD
- S QAQMMAX=QAQMMAX+1,QAQCHOSN(QAQFILE(QAQLEVEL))=""
- S ^TMP($J,"QAQTXT",1000+QAQMMAX,0)=" ;;"_+QAQTEXT(1)_"^"_QAQTEXT(2)_"^"_QAQTEXT(3)_"^"_QAQTEXT(4)
- G FLD
- EXIT ; *** Exit field questions loop
- Q
- LIST ; *** Display the fields already chosen
- N X W !!,"You have already selected the following: (Menu Item # Menu Text)",! S QAQ=$Y,QAQMMAX(0)=QAQMMAX#2+QAQMMAX\2
- F QA=1001:1:QAQMMAX(0)+1000 S QAI=QA,QAQTAB=0 D S QAI=QA+QAQMMAX(0),QAQTAB=40 D I ($Y>(IOSL+QAQ-4))!(QAQMMAX(0)+1000=QA) S QAQ=$Y K DIR S DIR(0)="E" D ^DIR K DIR S QAQQUIT=$S(Y'>0:1,1:0) Q:QAQQUIT
- . S X=$P($G(^TMP($J,"QAQTXT",QAI,0)),";;",2,99)
- . Q:X="" W:QAQTAB=0 !
- . W ?QAQTAB,$S($P(X,"^"):$J(QAI-1000,2),1:" ")," ",$P(X,"^",2)
- . Q
- Q
- CASE(QAQ) ; *** Convert text to initial capital letters
- N X,QA S X="" F QA=1:1:$L(QAQ) S X(0)=$E(QAQ,QA-1),X(1)=$E(QAQ,QA),X=X_$S(X(0)?.1P:$$U(X(1)),X(0)?1U:$$L(X(1)),X(1)?1U:$$L(X(1)),1:X(1))
- Q X
- U(X) Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- L(X) Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAQAHOCY 3688 printed Feb 18, 2025@23:57:49 Page 2
- QAQAHOCY ;HISC/DAD-AD HOC REPORTS: INTERFACE COMPILER ;7/12/95 14:57
- +1 ;;1.7;QM Integration Module;;07/25/1995
- +2 ;
- +3 SET (QAQMMAX,QAQSORT)=0
- SET QAQLEVEL=1
- SET QAQFILE(QAQLEVEL)=QAQFILE
- FLD ; *** Process the sort/print fields
- +1 WRITE !!,"Choose a field for menu item number ",QAQMMAX+1,", <RETURN> to end, ^ to exit."
- +2 WRITE !,"Select ",$SELECT(QAQLEVEL=1:"",1:$PIECE(QAQFILE(QAQLEVEL-1),"^",3)_" SUB-"),"FIELD: "
- READ X:DTIME
- if '$TEST
- SET X="^"
- SET QAQQUIT=$SELECT($EXTRACT(X)="^":1,1:0)
- +3 IF X="?"
- IF QAQMMAX
- DO LIST
- if QAQQUIT
- GOTO FLD
- WRITE !
- +4 KILL DIC
- SET DIC="^DD("_+QAQFILE(QAQLEVEL)_","
- SET DIC(0)="EMNQZ"
- SET DIC("W")="S QA=+$P(^(0),""^"",2) W:QA "" "",$S($P(^DD(QA,.01,0),""^"",2)[""W"":""(word-processing)"",1:""(multiple)"")"
- DO ^DIC
- +5 IF Y'>0
- if X=""
- SET QAQLEVEL=QAQLEVEL-1
- if 'QAQLEVEL!QAQQUIT
- GOTO EXIT
- GOTO FLD
- +6 ; *** QAQFILE(Level#) = Dict # ^ Fld # ^ Fld Name
- SET QAQDD=Y(0)
- SET $PIECE(QAQFILE(QAQLEVEL),"^",2,3)=+Y_"^"_$PIECE(QAQDD,"^")
- SET QAQWP=0
- +7 IF +$PIECE(QAQDD,"^",2)
- SET QAQWP=($PIECE(^DD(+$PIECE(QAQDD,"^",2),.01,0),"^",2)["W")
- IF 'QAQWP
- SET QAQLEVEL=QAQLEVEL+1
- SET QAQFILE(QAQLEVEL)=+$PIECE(QAQDD,"^",2)
- GOTO FLD
- +8 IF $DATA(QAQCHOSN(QAQFILE(QAQLEVEL)))#2
- WRITE !!?5,"*** You have already chosen that field !! ***",*7
- GOTO FLD
- +9 FOR QA=1:1:4
- SET QAQTEXT(QA)=""
- NAME ; *** Prompt user for the external field name
- +1 KILL DIR
- SET DIR(0)="FOA^2:30^K:X[""^"" X"
- SET DIR("A")="Menu text the user should see: "
- SET DIR("B")=$$CASE($PIECE(QAQDD,"^"))
- SET DIR("?")="^D EN^QAQAHOCH(""H7"")"
- +2 DO ^DIR
- if $DATA(DIRUT)
- GOTO FLD
- SET QAQTEXT(2)=Y
- SORT ; *** Allow sorting on this field (Y/N)
- +1 ; *** Don't ask sort questions for WP fields
- if QAQWP
- GOTO SETLINE
- +2 SET X=$PIECE(QAQDD,"^",2)
- SET %=$SELECT($PIECE(QAQFILE(QAQLEVEL),"^",2)=.01:1,X["F":2,X["K":2,X["V":2,1:1)
- +3 WRITE !,"Want to allow sorting by ",QAQTEXT(2)
- DO YN^DICN
- if %=-1
- GOTO FLD
- SET QAQTEXT(1)=(%=1)
- SET QAQSORT=QAQSORT+QAQTEXT(1)
- IF '%
- WRITE !!?5,QAQYESNO,!
- GOTO SORT
- DIR ; *** Set up DIR(0) for sort from/to prompts
- +1 SET X=$PIECE(QAQDD,"^",2)
- +2 if X["N"
- GOTO NUMERIC
- if X["P"
- GOTO POINTER
- if X["S"
- GOTO SET
- if X["D"
- GOTO DATE
- GOTO TEXT
- DATE SET QAQTEXT(4)="DAO^::AETS^D DATE^QAQAHOC2"
- GOTO SETLINE
- NUMERIC SET QAQTEXT(4)="NAO^-999999999:999999999:9^"
- GOTO SETLINE
- POINTER SET QA=$PIECE(QAQDD,"^",2)
- SET QA=$TRANSLATE(QA,$TRANSLATE(QA,".0123456789"))
- +1 SET QAQTEXT(4)="PAO^"_QA_":AEMNQZ^D POINTER^QAQAHOC2"
- GOTO SETLINE
- SET SET QAQTEXT(4)="SAO^"_$PIECE(QAQDD,"^",3)_"^D SET^QAQAHOC2"
- GOTO SETLINE
- TEXT SET QAQTEXT(4)="FAO^1:60^"
- SETLINE ; *** Save menu $TEXT line in ^TMP
- +1 FOR QA=1:1:QAQLEVEL
- SET QAQTEXT(3)=QAQTEXT(3)_$SELECT(QA=QAQLEVEL:"~",1:"")_$PIECE(QAQFILE(QA),"^",2)_$SELECT(QA'=QAQLEVEL:",",1:$SELECT(QAQTEXT(2)'=$PIECE(QAQFILE(QA),"^",3):";"""_$TRANSLATE(QAQTEXT(2),",;^~"," ")_"""",1:""))
- +2 SET Y=7+$LENGTH(QAQTEXT(2))+$LENGTH(QAQTEXT(3))+$LENGTH(QAQTEXT(4))-245
- IF Y>0
- WRITE !!?5,"*** This line is ",Y," character",$SELECT(Y>1:"s",1:"")," too long, maximum is 245 !! ***",*7
- GOTO FLD
- +3 SET QAQMMAX=QAQMMAX+1
- SET QAQCHOSN(QAQFILE(QAQLEVEL))=""
- +4 SET ^TMP($JOB,"QAQTXT",1000+QAQMMAX,0)=" ;;"_+QAQTEXT(1)_"^"_QAQTEXT(2)_"^"_QAQTEXT(3)_"^"_QAQTEXT(4)
- +5 GOTO FLD
- EXIT ; *** Exit field questions loop
- +1 QUIT
- LIST ; *** Display the fields already chosen
- +1 NEW X
- WRITE !!,"You have already selected the following: (Menu Item # Menu Text)",!
- SET QAQ=$Y
- SET QAQMMAX(0)=QAQMMAX#2+QAQMMAX\2
- +2 FOR QA=1001:1:QAQMMAX(0)+1000
- SET QAI=QA
- SET QAQTAB=0
- Begin DoDot:1
- +3 SET X=$PIECE($GET(^TMP($JOB,"QAQTXT",QAI,0)),";;",2,99)
- +4 if X=""
- QUIT
- if QAQTAB=0
- WRITE !
- +5 WRITE ?QAQTAB,$SELECT($PIECE(X,"^"):$JUSTIFY(QAI-1000,2),1:" ")," ",$PIECE(X,"^",2)
- +6 QUIT
- End DoDot:1
- SET QAI=QA+QAQMMAX(0)
- SET QAQTAB=40
- Begin DoDot:1
- End DoDot:1
- IF ($Y>(IOSL+QAQ-4))!(QAQMMAX(0)+1000=QA)
- SET QAQ=$Y
- KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- SET QAQQUIT=$SELECT(Y'>0:1,1:0)
- if QAQQUIT
- QUIT
- +7 QUIT
- CASE(QAQ) ; *** Convert text to initial capital letters
- +1 NEW X,QA
- SET X=""
- FOR QA=1:1:$LENGTH(QAQ)
- SET X(0)=$EXTRACT(QAQ,QA-1)
- SET X(1)=$EXTRACT(QAQ,QA)
- SET X=X_$SELECT(X(0)?.1P:$$U(X(1)),X(0)?1U:$$L(X(1)),X(1)?1U:$$L(X(1)),1:X(1))
- +2 QUIT X
- U(X) QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- L(X) QUIT $TRANSLATE(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
