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 Apr 09, 2024@21:33:50 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")
