source: WorldVistAEHR/trunk/r/QUALITY_ASSURANCE_INTEGRATION-QAQ/QAQAHOCY.m@ 1259

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1QAQAHOCY ;HISC/DAD-AD HOC REPORTS: INTERFACE COMPILER ;7/12/95 14:57
2 ;;1.7;QM Integration Module;;07/25/1995
3 ;
4 S (QAQMMAX,QAQSORT)=0,QAQLEVEL=1,QAQFILE(QAQLEVEL)=QAQFILE
5FLD ; *** Process the sort/print fields
6 W !!,"Choose a field for menu item number ",QAQMMAX+1,", <RETURN> to end, ^ to exit."
7 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)
8 I X="?",QAQMMAX D LIST G:QAQQUIT FLD W !
9 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
10 I Y'>0 S:X="" QAQLEVEL=QAQLEVEL-1 G EXIT:'QAQLEVEL!QAQQUIT,FLD
11 S QAQDD=Y(0),$P(QAQFILE(QAQLEVEL),"^",2,3)=+Y_"^"_$P(QAQDD,"^"),QAQWP=0 ; *** QAQFILE(Level#) = Dict # ^ Fld # ^ Fld Name
12 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
13 I $D(QAQCHOSN(QAQFILE(QAQLEVEL)))#2 W !!?5,"*** You have already chosen that field !! ***",*7 G FLD
14 F QA=1:1:4 S QAQTEXT(QA)=""
15NAME ; *** Prompt user for the external field name
16 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"")"
17 D ^DIR G:$D(DIRUT) FLD S QAQTEXT(2)=Y
18SORT ; *** Allow sorting on this field (Y/N)
19 G:QAQWP SETLINE ; *** Don't ask sort questions for WP fields
20 S X=$P(QAQDD,"^",2),%=$S($P(QAQFILE(QAQLEVEL),"^",2)=.01:1,X["F":2,X["K":2,X["V":2,1:1)
21 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
22DIR ; *** Set up DIR(0) for sort from/to prompts
23 S X=$P(QAQDD,"^",2)
24 G NUMERIC:X["N",POINTER:X["P",SET:X["S",DATE:X["D",TEXT
25DATE S QAQTEXT(4)="DAO^::AETS^D DATE^QAQAHOC2" G SETLINE
26NUMERIC S QAQTEXT(4)="NAO^-999999999:999999999:9^" G SETLINE
27POINTER S QA=$P(QAQDD,"^",2),QA=$TR(QA,$TR(QA,".0123456789"))
28 S QAQTEXT(4)="PAO^"_QA_":AEMNQZ^D POINTER^QAQAHOC2" G SETLINE
29SET S QAQTEXT(4)="SAO^"_$P(QAQDD,"^",3)_"^D SET^QAQAHOC2" G SETLINE
30TEXT S QAQTEXT(4)="FAO^1:60^"
31SETLINE ; *** Save menu $TEXT line in ^TMP
32 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:""))
33 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
34 S QAQMMAX=QAQMMAX+1,QAQCHOSN(QAQFILE(QAQLEVEL))=""
35 S ^TMP($J,"QAQTXT",1000+QAQMMAX,0)=" ;;"_+QAQTEXT(1)_"^"_QAQTEXT(2)_"^"_QAQTEXT(3)_"^"_QAQTEXT(4)
36 G FLD
37EXIT ; *** Exit field questions loop
38 Q
39LIST ; *** Display the fields already chosen
40 N X W !!,"You have already selected the following: (Menu Item # Menu Text)",! S QAQ=$Y,QAQMMAX(0)=QAQMMAX#2+QAQMMAX\2
41 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
42 . S X=$P($G(^TMP($J,"QAQTXT",QAI,0)),";;",2,99)
43 . Q:X="" W:QAQTAB=0 !
44 . W ?QAQTAB,$S($P(X,"^"):$J(QAI-1000,2),1:" ")," ",$P(X,"^",2)
45 . Q
46 Q
47CASE(QAQ) ; *** Convert text to initial capital letters
48 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))
49 Q X
50U(X) Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
51L(X) Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
Note: See TracBrowser for help on using the repository browser.