source: FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSDX3UB.m@ 1452

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

initial load of FOIAVistA 6/30/08 version
File size: 4.7 KB
Line 
1YSDX3UB ;SLC/DJP/LJA-Continuation of Utilities for Diagnosis Entry in the MH Medical Record ;09/07/94 13:11
2 ;;5.01;MENTAL HEALTH;;Dec 30, 1994
3 ;D RECORD^YSDX0001("^YSDX3UB") ;Used for testing. Inactivated in YSDX0001...
4 ;
5MODIF ; Called by routine YSDX3
6 ; Print out modifier questions
7 ;D RECORD^YSDX0001("MODIF^YSDX3UB") ;Used for testing. Inactivated in YSDX0001...
8 QUIT:'$D(^YSD(627.7,YSDXDA1,"Q",0)) ;->
9 W !!,"MODIFIERS: "
10 S K1=0
11 F K YSQT S K1=$O(^YSD(627.7,+YSDXDA1,"Q",K1)) Q:'K1 D I $D(YSQT) D DELETE^YSDX3UA QUIT ;->
12 . S K2=$P(^YSD(627.7,+YSDXDA1,"Q",+K1,0),U)
13 . D MQUES
14 . S:K2=36 YSALZ=1
15 QUIT
16MQUES ;
17 ;D RECORD^YSDX0001("MQUES^YSDX3UB") ;Used for testing. Inactivated in YSDX0001...
18 N YSTEST
19 S YSMODI=$P(^DIC(627.9,+K2,0),U,2)
20 ;
21 ; Set YSQIEN and check if is info only, or query... Exit if info only.
22 S YSQIEN=+K2
23 I '$D(^DIC(627.9,+YSQIEN,1)) D QUIT ;->
24 . S YSX=$P($G(^DIC(627.9,+YSQIEN,0)),U,2)
25 . W:YSX]"" !!,YSX
26 ;
27 ; Display prompt and get specifier...
28 D ASKQUAL^YSDX3UC
29 ;
30 ; Various QUITs...
31 I '$G(YSOK) S YSQT=1 QUIT ;-> YSOK set by ASKQUAL^YSDX3UC
32 I YSTOUT!YSUOUT S YSQT=1 QUIT ;->
33 I '$D(^DIC(627.9,+YSQIEN,1,"B")) S YSQT=1 QUIT ;->
34 I '$D(YSQCH) QUIT ;-> Do NOT set YSQT. User just did not select anything...
35 ;
36 D MSET ; Store selected modifier(s) in 627.8...
37 ;
38 QUIT
39 ;
40DQP(YSPEC) ; Display Qualifier Prompt (Specifier)
41 ; Note: Cursor should be at beginning of line when DQP call made.
42 QUIT:$G(YSPEC)']"" ;->
43 N YSX,YSY,YSZ
44 ;
45 ; Change =s to .s
46 S YSZ("=")=". "
47 S YSZ(" - :")=":"
48 S YSPEC=$$REPLACE^XLFSTR(YSPEC,.YSZ)
49 ;
50 ; Itemized specifiers text...
51 I YSPEC[":" D QUIT ;->
52 . D DQP1($P(YSPEC,":")) W ":" ;Print prompt
53 . S YSPEC=$P(YSPEC,":",2,99) ;Cut off prompt
54 . F QUIT:$E(YSPEC)'=" " S YSPEC=$E(YSPEC,2,999) ;Trim leading spaces
55 .
56 . W:$X>9 ! W ?10
57 . F YSX=1:1:$L(YSPEC,";") S YSY=$P(YSPEC,";",+YSX) I YSY]"" D
58 . . F QUIT:$E(YSY)'=" " S YSY=$E(YSY,2,999) ;Trim leading spaces
59 . . I $L(YSY)<(IOM-13) W YSY,!,?10 QUIT ;->
60 . . F YSI=(IOM-13):-1:1 QUIT:$E(YSY,YSI)=" "
61 . . S YSI=$S(YSI:YSI,1:IOM-13)
62 . . W $E(YSY,1,YSI),!,?13,$E(YSY,YSI+1,999)
63 . . W !,?10
64 ;
65 ; Non-itemized specifiers text...
66 I $E(YSPEC,1,8)'[":" D DQP1(YSPEC)
67 QUIT
68 ;
69DQP1(YSPEC) ;Print prompt with proper wrapping...
70 ; After call, cursor is left at end of last line...
71 QUIT:$G(YSPEC)']"" ;->
72 W:$X>1 !
73 N YSX
74 F D QUIT:YSPEC']"" ;->
75 . I $L(YSPEC)<(IOM) W YSPEC S YSPEC="" QUIT ;->
76 . F YSX=IOM:-1:1 QUIT:$E(YSPEC,YSX)=" "
77 . S YSX=$S(YSX:YSX,1:$L(YSPEC))
78 . W $E(YSPEC,1,+YSX)
79 . S YSPEC=$E(YSPEC,+YSX+1,999)
80 . W:YSPEC]"" ! ;More to print, so have to insert a line feed...
81 QUIT
82 ;
83YN ;
84 ;D RECORD^YSDX0001("YN^YSDX3UB") ;Used for testing. Inactivated in YSDX0001...
85 S K3=$TR(K3,"yn","YN")
86 I K3["?" D QUIT ;->
87 . W !!,"Diagnosis may be modified. Answer ""YES"" or ""NO""."
88 . S K5=1
89 I "Y"'[K3&("N"'[K3) W "??" S K5=1 QUIT ;->
90 I "Y"[K3 S K3=1
91 I "Y"'[K3 S K3=2
92 QUIT
93 ;
94NUM ;
95 ;D RECORD^YSDX0001("NUM^YSDX3UB") ;Used for testing. Inactivated in YSDX0001...
96 I K3="?" D QUIT ;->
97 . W !!,"Diagnosis may be modified. Answer with corresponding numeric."
98 . S K5=1
99 I K3="??"&(K2=1) S XQH="YS-GEN MODIFIER" D EN^XQH S K5=1 QUIT ;->
100 I K3'?1.N W "??" S K5=1 QUIT ;->
101 S N=$P(^DIC(627.9,+K2,1,0),U,3)
102 I K3<1!(K3>N) W !!,"Answer with corresponding numeric." S K5=1 QUIT ;->
103 QUIT
104 ;
105MSET ;
106 ;D RECORD^YSDX0001("MSET^YSDX3UB") ;Used for testing. Inactivated in YSDX0001...
107 ; YSQCH( -- req
108 QUIT:'$D(YSQCH) ;->
109 N DA,DIE,DR,YSLP,YSQIEN,YSQSFOR,YSQUSEL
110 L +^YSD(627.8,YSDA)
111 S DIE="^YSD(627.8,",DA=YSDA
112 S YSLP="YSQCH"
113 F S YSLP=$Q(@YSLP) QUIT:YSLP'["YSQCH(" D
114 . S YSQIEN=+$P(YSLP,"(",2),YSQUSEL=$P($P(YSLP,",",2),")")
115 . QUIT:YSQIEN'>0!(YSQUSEL']"") ;->
116 . S X=@YSLP,YSQSFOR=$S($TR(X," ","")="":"",1:X)
117 . S DR="50///"_+YSQIEN
118 . S DR(2,627.82)="1///"_$TR(YSQUSEL,"""","")
119 . I YSQSFOR]"" S DR(2,627.82)=DR(2,627.82)_";2///"_YSQSFOR
120 . D ^DIE
121 L -^YSD(627.8,YSDA)
122 QUIT
123 ;
124GAF ; Called by routine YSDX3B, YSDX3RUA
125 ; Calculates the highest GAF for the past year. YSGAF(X) stores scale^DA.
126 ;D RECORD^YSDX0001("GAF^YSDX3UB") ;Used for testing. Inactivated in YSDX0001...
127 K G5 S (G,G2)=0
128 F S G=$O(^YSD(627.8,"AX5",YSDFN,G)) Q:'G D
129 . S G1=0
130 . F S G1=$O(^YSD(627.8,"AX5",YSDFN,G,G1)) Q:'G1 D GAF1
131 I $D(YSGAF) S G5=0 D
132 . F I=1:1:G2 S G6=$P(YSGAF(I),U) I G6>G5 S G5=G6,G10=$P(YSGAF(I),U,2)
133 . S Y=$P(^YSD(627.8,G10,0),U,3) D DD^%DT S G11=$P(Y,"@")
134 QUIT
135 ;
136GAF1 ;
137 ;D RECORD^YSDX0001("GAF1^YSDX3UB") ;Used for testing. Inactivated in YSDX0001...
138 S %DT="",X="T" D ^%DT S G4=(Y-$P($P(^YSD(627.8,G1,0),U,3),"."))
139 QUIT:G4>10000 ;->
140 S G2=G2+1,YSGAF(G2)=$P(^YSD(627.8,G1,60),U,3)_"^"_G1
141 QUIT
142 ;
143EOR ;YSDX3UB-Continuation of Utilities for Diagnosis Entry in the MH Medical Record ;9/18/91 15:39
Note: See TracBrowser for help on using the repository browser.