source: WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSASLIB.m@ 623

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

initial load of WorldVistAEHR

File size: 3.8 KB
Line 
1YSASLIB ;692/DCL-ASI LIBRARY FUNCTIONS ;1/13/97 09:51
2 ;;5.01;MENTAL HEALTH;**24,37**;Dec 30, 1994
3 Q
4 ;
5ID(YSAS) ;Identifiers for file 604, pass Y (IEN)
6 Q:$G(YSAS)'>0 ""
7 N YSASN,YSASD,YSAST,YSAS0,DIERR
8 S YSAS0=^YSTX(604,YSAS,0),YSASN=$P(YSAS0,"^",2)
9 S:YSASN>0 YSASN=$P(^DPT(YSASN,0),"^")
10 S YSASD=$$FMTE^XLFDT($P(YSAS0,U,5),"5ZD")
11 S YSAST=$$GET1^DIQ(604,YSAS_",",.04)
12 Q $J("",(10-$L(YSAS)))_YSASN_$J("",(30-$L(YSASN)))_$J(YSASD,10)_" "_YSAST
13 ;
14FUID(YSAS) ;Identifiers for file 604, pass Y (IEN) used when listing FOLLOW-UP ASI.
15 Q:$G(YSAS)'>0 ""
16 N YSASN,YSASD,YSASF,YSASFN,YSAS0,DIERR,YSASP
17 S YSAS0=^YSTX(604,YSAS,0),YSASN=$P(YSAS0,"^",2)
18 S:YSASN>0 YSASN=$P(^DPT(YSASN,0),"^")
19 S YSASD=$P($P($G(^YSTX(604,YSAS,11)),"^",10),"@")
20 S YSASF=$P($G(^YSTX(604,YSAS,12)),"^",3),YSASP=$P(^(12),"^",2)
21 S YSASFN=$S(YSASF>0:$P($G(^YSTX(604.5,YSASF,0)),"^"),1:"")
22 Q $J("",(10-$L(YSAS)))_YSASN_$J("",(30-$L(YSASN)))_$J(YSASD,8)_$J(YSASP,9)_" "_YSASFN
23 ;
24PID(YSAS) ;Identifiers for Patient file, #2 - pass Y (IEN)
25 Q:$G(YSAS)'>0
26 N YSASDOB,YSASSSN,YSAS0
27 S YSAS0=^DPT(YSAS,0),YSASDOB=$$DT($P(YSAS0,"^",3))
28 S YSASSSN=$$SSN($P(YSAS0,"^",9)),YSASN=$P(YSAS0,"^")
29 Q $J("",(30-$L(YSASN)))_" "_$J(YSASDOB,8)_" "_$J(YSASSSN,12)
30 ;
31DT(X) ;Convert date to external format
32 Q:$G(X)="" ""
33 Q $$FMTE^XLFDT(X,"5ZD")
34 ;
35SSN(X) ;Convert ssn to external format
36 Q:$G(X)="" ""
37 Q $E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,9)
38 ;
39NEW() ;Adding New Entries - return an internal number - EXTRINSIC FUNCTION
40 N AUI2X
41 F AUI2X=$P(^YSTX(604,0),U,3):1 I '$D(^YSTX(604,AUI2X)) L ^YSTX(604,AUI2X):0 Q:$T
42 Q AUI2X
43 ;
44NEW047(D0) ;Adding new sub-entry and return an internal number - EXTRINSIC
45 Q:'$G(D0) ""
46 Q:'$P(^YSTX(604,D0,.047,0),"^",3) 1
47 N YSASX
48 F YSASX=$P(^YSTX(604,D0,.047,0),"^",3):1 I '$D(^YSTX(604,D0,.047,YSASX)) L ^YSTX(604,D0,.047,YSASX):0 Q:$T
49 Q YSASX
50 ;
51VL() ;
52 I '$D(IOVL) D GSET^%ZISS
53 Q IOG1_IOVL_IOG0
54 ;
55X(X,F,T) ;Check is X is integer or NN or XX and return truth value TO KILL X (INPUT TRANSFORM)
56 ;Pass From To value for integers ie 0,9, 1,99 or 1,9999.
57 I X?1N.N,$G(F)]"",$G(T)]"",X'<F,X'>T Q 0
58 I X="NN" Q 0
59 I X="XX" Q 0
60 I X="X" Q 0
61 Q 1
62 ;
63USI(YSADUZ) ;Unsigned Intakes, pass user's duz and return total number of unsigned intakes
64 Q:$G(YSADUZ)'>0 ""
65 N C,D,X
66 S (C,X)=0,D="A.81."_YSADUZ
67 F S X=$O(^YSTX(604,D,X)) Q:X'>0 I $P(^YSTX(604,X,0),"^",4)=1 S C=C+1
68 Q C
69 ;
70USF(YSADUZ) ;Unsigned Follow-ups, pass user's duz and return total number on unsigned follow-ups
71 Q:$G(YSADUZ)'>0 ""
72 N C,D,X
73 S (C,X)=0,D="A.81."_YSADUZ
74 F S X=$O(^YSTX(604,D,X)) Q:X'>0 I $P(^YSTX(604,X,0),"^",4)=2 S C=C+1
75 Q C
76 ;
77US(YSADUZ) ;Unsigned ASIs return in 2 piece string #INTAKEs^#FOLLOW-UPs
78 Q:$G(YSADUZ)'>0 ""
79 N C,C1,C2,C3,D,X
80 S (C1,C2,C3,X)=0,D="A.81."_YSADUZ
81 F S X=$O(^YSTX(604,D,X)) Q:X'>0 D
82 .S C=$P(^YSTX(604,X,0),"^",4)
83 .Q:C'>0
84 .I C=1 S C1=C1+1 Q
85 .I C=2 S C2=C2+1 Q
86 .I C=3 S C3=C3+1 Q
87 .Q
88 Q C1_"^"_C2_"^"_C3
89 ;
90DISP(YSADUZ,YSASCLS) ;Display ASI requiring signature - pass DUZ and CLASS (ASI TYPE)
91 Q:$G(YSADUZ)'>0
92 Q:$G(YSASCLS)'>0
93 N C,C1,C2,D,X,X0,X11
94 S (C1,C2,X)=0,D="A.81."_YSADUZ
95 W !
96 F S X=$O(^YSTX(604,D,X)) Q:X'>0 D
97 .S X0=^YSTX(604,X,0),X11=$G(^(11)),C=$P(X0,"^",4)
98 .Q:C'>0
99 .Q:C'=YSASCLS
100 .W !?4,X,?14,$P(^DPT($P(X0,"^",2),0),"^"),?46,$P(X11,"^",10)
101 .Q
102 W !
103 Q
104 ;
105 ;
106INTRO ;
107 W:$D(IOF) @IOF
108 W !?20,"ADDICTION SEVERITY INDEX",!?25,"FIFTH EDITION",!!
109 D STATUS()
110 Q
111STATUS(YSAU) ;Return status of unsigned ASIs on a user.
112 S:$G(YSAU)'>0 YSAU=DUZ
113 N YSAS,X
114 S YSAS=$$US(YSAU)
115 F I=1:1:3 S X=$P(YSAS,U,I) D:X
116 .W !,"You have ",$J(X,3)," unsigned ASI ",$S(I=2:"Lite",I=3:"Followup",1:"Full Intake"),$S(X>1:"s",1:""),"."
117 .Q
118 Q
119RACE(X) ;Pass file 2 race code and return ASI race code, if possible.
120 Q:$G(X)'>0 ""
121 I X=1 Q 2
122 I X=3 Q 1
123 I X=5 Q 5
124 Q ""
125REL(X) ;Pass file 2 religion code and return ASI religion code, if possible.
126 Q:$G(X)'>0 ""
127 I X=1 Q 3
128 I X=20 Q 4
129 I X=22 Q 5
130 I X=99 Q 2
131 Q ""
132 ;
Note: See TracBrowser for help on using the repository browser.