source: WorldVistAEHR/trunk/r/SPINAL_CORD_DYSFUNCTION-SPN/SPNAHOCY.m@ 1261

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

initial load of WorldVistAEHR

File size: 4.5 KB
Line 
1SPNAHOCY ;HISC/DAD-AD HOC REPORTS: INTERFACE COMPILER ;9/9/96 11:44
2 ;;2.0;Spinal Cord Dysfunction;;01/02/1997
3 ;
4 S (SPNMMAX,SPNSORT)=0,SPNLEVEL=1,SPNFILE(SPNLEVEL)=SPNFILE
5FLD ; *** Process the sort/print fields
6 W !!,"Choose a field for menu item number ",SPNMMAX+1
7 W ", <RETURN> to end, ^ to exit."
8 W !,"Select ",$S(SPNLEVEL=1:"",1:$P(SPNFILE(SPNLEVEL-1),U,3)_" SUB-")
9 W "FIELD: " R X:DTIME S:'$T X=U S SPNQUIT=$S($E(X)=U:1,1:0)
10 I X="?",SPNMMAX D LIST G:SPNQUIT FLD W !
11 K DIC S DIC="^DD("_+SPNFILE(SPNLEVEL)_",",DIC(0)="EMNQZ"
12 S DIC("W")="W "" "",$$ID^SPNAHOCY"
13 D ^DIC S SPNY=Y
14 I SPNY'>0 S:X="" SPNLEVEL=SPNLEVEL-1 G EXIT:'SPNLEVEL!SPNQUIT,FLD
15 S SPNATTR="LABEL;MULTIPLE-VALUED;POINTER;SPECIFIER;TYPE" K SPNDD,SPNERR
16 D FIELD^DID(+SPNFILE(SPNLEVEL),+SPNY,"",SPNATTR,"SPNDD","SPNERR")
17 I $O(SPNERR(""))]"" W " ??",$C(7) G FLD
18 S SPNDD=SPNDD("LABEL")_U_SPNDD("SPECIFIER")_U_SPNDD("POINTER")
19 S $P(SPNFILE(SPNLEVEL),U,2,3)=+SPNY_U_$P(SPNDD,U),SPNWP=0
20 ; *** SPNFILE(Level#) = Dict # ^ Fld # ^ Fld Name
21 I +$P(SPNDD,U,2) D G:'SPNWP FLD
22 . S SPNWP=(SPNDD("TYPE")="WORD-PROCESSING")
23 . I 'SPNWP S SPNLEVEL=SPNLEVEL+1,SPNFILE(SPNLEVEL)=+$P(SPNDD,U,2)
24 . Q
25 I $D(SPNCHOSN(SPNFILE(SPNLEVEL)))#2 D G FLD
26 . W !!?5,"*** You have already chosen that field !! ***",$C(7)
27 . Q
28 F SP=1:1:5 S SPNTEXT(SP)=""
29NAME ; *** Prompt user for the external field name
30 K DIR S DIR(0)="FOA^2:30^K:X[U X",DIR("?")="^D EN^SPNAHOCH(""H7"")"
31 S DIR("A")="Menu text the user should see: "
32 S DIR("B")=$$CASE($P(SPNDD,U))
33 D ^DIR G:$D(DIRUT) FLD S SPNTEXT(2)=Y
34SORT ; *** Allow sorting on this field (Y/N)
35 G:SPNWP SETLINE ; *** Don't ask sort questions for WP fields
36 F D Q:%
37 . S X=$P(SPNDD,U,2)
38 . S %=$S($P(SPNFILE(SPNLEVEL),U,2)=.01:1,X["F":2,X["K":2,X["V":2,1:1)
39 . W !,"Want to allow sorting by ",SPNTEXT(2)
40 . D YN^DICN S SPNTEXT(1)=(%=1),SPNSORT=SPNSORT+SPNTEXT(1)
41 . I '% W !!?5,SPNYESNO,!
42 . Q
43 G:%=-1 FLD
44SCREEN ; *** Prompt user for screen on pointers and sets
45 S X=$P(SPNDD,U,2)
46 I SPNTEXT(1),$TR(X,$TR(X,"PS"))]"" D G:$D(DTOUT)!$D(DUOUT)!$D(DIROUT) FLD
47 . F D Q:SPNTEXT(5)]""!$D(DIRUT)
48 .. K DIR S DIR(0)="FOAU^1:245^"
49 .. S DIR("A")="Sort from/to look-up screen: "
50 .. S DIR("?")="^D EN^SPNAHOCH(""H12"")"
51 .. D ^DIR I Y=""!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q
52 .. S X=Y D ^DIM
53 .. I $G(X)]"" S SPNTEXT(5)=X
54 .. E W " ??",$C(7)
55 .. Q
56 . Q
57DIR ; *** Set up DIR(0) for sort from/to prompts
58 S X=$P(SPNDD,U,2)
59 G NUMERIC:X["N",POINTER:X["P",SET:X["S",DATE:X["D",TEXT
60DATE S SPNTEXT(4)="DAO^::AETS^D DATE^SPNAHOC2" G SETLINE
61NUMERIC S SPNTEXT(4)="NAO^-999999999:999999999:9^" G SETLINE
62POINTER S SP=$P(SPNDD,U,2),SP=$TR(SP,$TR(SP,".0123456789"))
63 S SPNTEXT(4)="PAO^"_SP_":AEMNQZ^D POINTER^SPNAHOC2" G SETLINE
64SET S SPNTEXT(4)="SAOM^"_$P(SPNDD,U,3)_"^D SET^SPNAHOC2" G SETLINE
65TEXT S SPNTEXT(4)="FAO^1:60^"
66SETLINE ; *** Save menu $TEXT line in ^TMP
67 F SP=1:1:SPNLEVEL S SPNTEXT(3)=SPNTEXT(3)_$S(SP=SPNLEVEL:"~",1:"")_$P(SPNFILE(SP),U,2)_$S(SP'=SPNLEVEL:",",1:$S(SPNTEXT(2)'=$P(SPNFILE(SP),U,3):";"""_$TR(SPNTEXT(2),",;^~"," ")_"""",1:""))
68 S Y=8+$L(SPNTEXT(2))+$L(SPNTEXT(3))+$L(SPNTEXT(4))+$L(SPNTEXT(5))-245
69 I Y>0 D G FLD
70 . W !!?5,"*** This line is ",Y," character",$S(Y>1:"s",1:"")
71 . W " too long, maximum is 245 !! ***",$C(7)
72 . Q
73 S SPNMMAX=SPNMMAX+1,SPNCHOSN(SPNFILE(SPNLEVEL))=""
74 S ^TMP($J,"SPNTXT",1000+SPNMMAX,0)=" ;;"_+SPNTEXT(1)_U_SPNTEXT(2)_U_SPNTEXT(3)_U_SPNTEXT(4)_"|"_SPNTEXT(5)
75 G FLD
76EXIT ; *** Exit field questions loop
77 Q
78LIST ; *** Display the fields already chosen
79 N X
80 W !!,"You have already selected the following: (Menu Item # Menu Text)",!
81 S SPN=$Y,SPNMMAX(0)=SPNMMAX#2+SPNMMAX\2
82 F SP=1001:1:SPNMMAX(0)+1000 D Q:SPNQUIT
83 . S SPI=SP,SPNTAB=0 D S SPI=SP+SPNMMAX(0),SPNTAB=40 D
84 .. S X=$P($G(^TMP($J,"SPNTXT",SPI,0)),";;",2,99)
85 .. Q:X="" W:SPNTAB=0 !
86 .. W ?SPNTAB,$S($P(X,U):$J(SPI-1000,2),1:" ")," ",$P(X,U,2)
87 .. Q
88 . I ($Y>(IOSL+SPN-4))!(SPNMMAX(0)+1000=SP) D
89 .. S SPN=$Y K DIR S DIR(0)="E" W ! D ^DIR K DIR S SPNQUIT=$S(Y'>0:1,1:0)
90 .. Q
91 . Q
92 Q
93CASE(SPN) ; *** Convert text to initial capital letters
94 N X,SP S X=""
95 F SP=1:1:$L(SPN) D
96 . S X(0)=$E(SPN,SP-1),X(1)=$E(SPN,SP)
97 . S X=X_$S(X(0)?.1P:$$U(X(1)),X(0)?1U:$$L(X(1)),X(1)?1U:$$L(X(1)),1:X(1))
98 . Q
99 Q X
100U(X) Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
101L(X) Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
102ID() ; *** DD identifiers
103 N SPNDD,SPNERR,SPNID S SPNID=""
104 D FIELD^DID(+SPNFILE(SPNLEVEL),+Y,"","SPECIFIER;TYPE","SPNDD","SPNERR")
105 I $O(SPNERR(""))="" D
106 . I SPNDD("SPECIFIER") S SPNID="(multiple)"
107 . I SPNDD("TYPE")="WORD-PROCESSING" S SPNID="("_$$L(SPNDD("TYPE"))_")"
108 . Q
109 Q SPNID
Note: See TracBrowser for help on using the repository browser.