source: FOIAVistA/trunk/r/HEALTH_SUMMARY-GMTS/GMTSGAF.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 7.4 KB
Line 
1GMTSGAF ; SLC/KER - MH Gbl Assessment Funct (GAF) ; 6/20/05 1:44pm
2 ;;2.7;Health Summary;**35,44,49,74**;Oct 20, 1995
3 ;
4 ; External References
5 ; DBIA 10035 ^DPT(
6 ; DBIA 10003 ^%DT
7 ; DBIA 10088 DEM^VADPT
8 ; DBIA 10103 $$FMADD^XLFDT
9 ; DBIA 10103 $$FMTE^XLFDT
10 ; DBIA 10103 $$NOW^XLFDT
11 ; DBIA 2896 GAFHX^YSGAFAPI
12 ;
13 Q
14EN ; Global Assessment Functioning Score
15 N MAX S MAX=$S(+($G(GMTSNDM))>0:+($G(GMTSNDM)),1:9999999)
16 S:+($G(GMTSBEG))'>2700101 GMTSBEG=$$FMADD^XLFDT($P($$NOW^XLFDT,".",1),-1095,0,0,1),GMTSEND=$$FMADD^XLFDT($P($$NOW^XLFDT,".",1),1,0,0,1),GMTS2=9999999-GMTSBEG,GMTS1=9999999-GMTSEND
17 S:'$L($P(GMTSBEG,".",2)) GMTSBEG=$$FMADD^XLFDT(GMTSBEG,0,0,0,1)
18 S:+($G(GMTSEND))'>2700101!(+($G(GMTSEND))>+($$FMADD^XLFDT($P($$NOW^XLFDT,".",1),+1,0,0,2))) GMTSEND=$$FMADD^XLFDT($P($$NOW^XLFDT,".",1),1,0,0,1),GMTS1=9999999-GMTSEND
19 S:'$L($P(GMTSEND,".",2)) GMTSEND=$$FMADD^XLFDT(GMTSEND,0,0,0,1)
20 S:+($G(GMTSEND))>0&(+($G(GMTS1))=0) GMTS1=9999999-GMTSEND S:+($G(GMTSBEG))>0&(+($G(GMTS2))=0) GMTS2=9999999-GMTSBEG
21 S GMTSLO=+($G(GMTSLO)) S:GMTSLO=0 GMTSLO=3 S GMTSLPG=+($G(GMTSLPG)),GMTSDTM=$G(GMTSDTM) S:'$L(GMTSDTM) GMTSDTM=$$DTM
22 S:'$D(GMTSTITL)!('$L($G(GMTSTITL))) GMTSTITL="GLOBAL ASSESSMENT FUNCTIONING"
23 S DFN=+($G(DFN)) Q:'$L($P($G(^DPT(DFN,0)),"^",1))
24 N %,%DT,%H,%I,%T,%X,I,N,VA,VADM,VAERR,X,Y,YS,YSGAF
25 N GMTSBAR,GMTSCNT,GMTSCOM,GMTSCORE,GMTSCS,GMTSCW,GMTSDATE,GMTSDT
26 N GMTSGAF,GMTSGAF1,GMTSGAF2,GMTSGAF3,GMTSGAFN,GMTSI,GMTSJ,GMTSLEN,GMTSPROV,GMTSRV
27 S GMTSGAF1=$$EXT(+($G(GMTS1))),GMTSGAF2=$$ITM(+($G(GMTS2))),GMTSGAF3=$$TOM
28 S GMTSGAFN=+($G(MAX)) S:GMTSGAFN=0 GMTSGAFN=10
29 S GMTSCW(0)=+($G(IOM)) S:GMTSCW(0)=0 GMTSCW(0)=80
30 S GMTSCW(1)=5,GMTSCW(2)=10,GMTSCW(3)=20,GMTSCW(4)=GMTSCW(0)-(GMTSCW(1)+GMTSCW(2)+GMTSCW(3)+8)
31 S GMTSCW("L")=(GMTSCW(1)+GMTSCW(2)+GMTSCW(3)+GMTSCW(4)+6)
32 S GMTSCS(1)=1,GMTSCS(2)=GMTSCS(1)+GMTSCW(1)+2,GMTSCS(3)=GMTSCS(2)+GMTSCW(2)+2,GMTSCS(4)=GMTSCS(3)+GMTSCW(3)+2
33 S YS("DFN")=DFN,YS("BEGIN")=$S($L(GMTSGAF2):GMTSGAF2,1:GMTSGAF3)
34 S YS("END")=$S($L(GMTSGAF1):GMTSGAF1,1:"01/01/1970"),YS("LIMIT")=GMTSGAFN
35 D GET Q:'$D(^TMP($J,"GMTSGAF",DFN)) D OUT Q
36OUT ; Output
37 N GMTSI,GMTSJ,GMTSCORE,GMTSDATE,GMTSPROV,GMTSCOM S DFN=+($G(DFN)) Q:DFN=0 D HDR S GMTSI=0 F S GMTSI=$O(^TMP($J,"GMTSGAF",DFN,GMTSI)) Q:+GMTSI=0 D
38 . S GMTSJ=$G(^TMP($J,"GMTSGAF",DFN,GMTSI))
39 . S GMTSCORE=$P(GMTSJ,"^",1),GMTSDATE=$P(GMTSJ,"^",2),GMTSPROV=$P(GMTSJ,"^",3),GMTSCOM=$P(GMTSJ,"^",4) S:GMTSCORE=""&(GMTSDATE["----")&($L(GMTSCOM)) GMTSCORE=">>" D LINE
40 K ^TMP($J,"GMTSGAF",DFN) Q
41LINE ; Output One Line
42 D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG=1 HDR W ?GMTSCS(1),$J($E(GMTSCORE,1,3),3),?GMTSCS(2),GMTSDATE,?GMTSCS(3),$E(GMTSPROV,1,GMTSCW(3)),?GMTSCS(4),GMTSCOM,! Q
43HDR ; Header
44 N GMTSI S GMTSI="",$P(GMTSI,"-",+($G(GMTSCW("L"))))="-"
45 D CKP^GMTSUP Q:$D(GMTSQIT) G:GMTSNPG=1 HDR W ?GMTSCS(1)," GAF ",?GMTSCS(2),"Date",!
46 D CKP^GMTSUP Q:$D(GMTSQIT) G:GMTSNPG=1 HDR W ?GMTSCS(1),"Score",?GMTSCS(2),"Determined",?GMTSCS(3),"Determined by",?GMTSCS(4),"Graph/Comment",!
47 D CKP^GMTSUP Q:$D(GMTSQIT) G:GMTSNPG=1 HDR W ?GMTSCS(1),GMTSI,!
48 Q
49GET ; Get and Format Data
50 N %DT,X,Y,GMTSGPH,GMTSCORE,GMTSDT,GMTSDATE,GMTSPROV,GMTSCOM S DFN=+($G(DFN)),GMTSGPH=0 K ^TMP($J,"GMTSGAF",DFN),YSGAF D GAFHX^YSGAFAPI(.YSGAF,.YS),SPC
51 I +($P($G(YSGAF("DEC")),".",1))>0 D
52 . S GMTSDT=+($P($G(YSGAF("DEC")),".",1)),GMTSCOM="Deceased ("_$$FMTE^XLFDT(GMTSDT,"5ZD")_")" D SD(GMTSDT,DFN,"","","",GMTSCOM)
53 I +($P($G(YSGAF("DUE")),".",1))>0 D
54 . S GMTSDT=+($P($G(YSGAF("DUE")),".",1)) Q:GMTSDT>$$TOD S GMTSCOM="Due since "_$$FMTE^XLFDT(GMTSDT,"5ZD") D SD(GMTSDT,DFN,"","","",GMTSCOM)
55 N I S I=1 F S I=$O(YSGAF(I)) Q:+I=0 D
56 . S GMTSDT=$P(YSGAF(I),"^",1),GMTSDATE=$P(GMTSDT,".",1),GMTSDATE=$$FMTE^XLFDT(GMTSDATE,"5ZD")
57 . Q:+($G(YSGAF("DEC")))>0&(+GMTSDATE>+($G(YSGAF("DEC"))))
58 . S GMTSCORE=$P(YSGAF(I),"^",5),GMTSPROV=$P(YSGAF(I),"^",7)
59 . S GMTSCOM=+($P($G(YSGAF("ERR",I)),".",1)) S:+GMTSCOM=0 GMTSCOM=""
60 . S:+GMTSCOM>0 GMTSCOM="Entered in error ("_$$FMTE^XLFDT(GMTSCOM,"5ZD")_")"
61 . S:GMTSCOM="" GMTSCOM=$$B(GMTSCORE,31)
62 . D:'$D(YSGAF("ERR",I)) SD(GMTSDT,DFN,GMTSCORE,GMTSDATE,GMTSPROV,GMTSCOM)
63 Q
64SPC ; Get Special Case (Deceased, Due, Entered-in-Error)
65 N GMTSI S YSGAF("P")=$P($G(^DPT(+($G(DFN)),0)),"^",1)
66 S GMTSI=$$DEC(+($G(DFN))) S:+GMTSI>0 YSGAF("DEC")=GMTSI I +GMTSI=0 S GMTSI=$$DUE S:+GMTSI>0 YSGAF("DUE")=GMTSI
67 K:+($G(YSGAF("DEC")))>0 YSGAF("DUE") S GMTSI=$$ERR S:+GMTSI>0 YSGAF("ERR")=GMTSI
68 Q
69SD(GMTSI,DFN,GMTSCORE,GMTSDATE,GMTSPROV,GMTSCOM) ; Save Data
70 N GMTSIG S (GMTSCORE,GMTSIG)=$G(GMTSCORE),GMTSCORE=$$GAF(GMTSCORE),DFN=+($G(DFN))
71 S GMTSIG=100-(+($G(GMTSIG)))
72 S GMTSI=+($G(GMTSI)),GMTSI=9999999.999999-GMTSI
73 S GMTSPROV=$G(GMTSPROV),GMTSDATE=$G(GMTSDATE)
74 S GMTSIG=GMTSI_GMTSIG_GMTSPROV_GMTSDATE
75 S:GMTSDATE="" GMTSDATE="--/--/----"
76 S ^TMP($J,"GMTSGAF",DFN,GMTSIG)=GMTSCORE_"^"_GMTSDATE_"^"_GMTSPROV_"^"_$G(GMTSCOM)
77 Q
78ERR(X) ; Entered in Error
79 N GMTSCNT,GMTSI,GMTSGAF,GMTSJ,GMTSDATE S (GMTSCNT,GMTSI)=0,GMTSDATE="" F S GMTSI=$O(YSGAF(GMTSI)) Q:+GMTSI=0 D
80 . S GMTSGAF=$P(YSGAF(GMTSI),"^",8) Q:GMTSGAF'["entered in error"
81 . S YSGAF("ERR")="" F GMTSJ=1:1:$L(GMTSGAF," ") D
82 .. S:$P(GMTSGAF," ",GMTSJ)["@"&(GMTSJ>2) GMTSDATE=$P(GMTSGAF," ",GMTSJ-1,GMTSJ) S:$L(GMTSDATE) GMTSDATE=$$ETF(GMTSDATE)
83 . S:$L(GMTSDATE) YSGAF("ERR",GMTSI)=GMTSDATE,GMTSCNT=GMTSCNT+1
84 S X=GMTSCNT Q X
85DUE(X) ; GAF Score Due Date
86 S:'$D(YSGAF(2)) YSGAF(1)="[NO DATA]" N GMTSI,GMTSJ,GMTSDATE S (GMTSI,GMTSJ,GMTSDATE)=0
87 F S GMTSI=$O(YSGAF(GMTSI)) Q:+GMTSI=0 S GMTSJ=$P(YSGAF(GMTSI),"^",1) S:GMTSJ>GMTSDATE GMTSDATE=GMTSJ
88 S GMTSDATE=$S(GMTSDATE>0:$$FMADD^XLFDT(GMTSDATE,90,0,0,0),1:"") S X=GMTSDATE Q X
89ITM(X) ; convert inverse internal date to internal date to external date
90 N SAVX ; temp scratch variable to hold value of X
91 S X=+($G(X)),X=9999999-X ; produce an internal date
92 S SAVX=X
93 S X=$$FMTE^XLFDT(X,"5ZD") D ^%DT I Y=-1 D ; if not valid date, default to 3 years ago
94 . S X1=$$NOW^XLFDT,X2=-1095 D C^%DTC S SAVX=X
95 S X=SAVX
96 S X=$$FMTE^XLFDT(X,"5ZD") ; produce external format
97 Q X
98EXT(X) ; convert inverse internal date to internal date, add one day, then to external date
99 N SAVX ; temp scratch variable to hold value of X
100 S X=+($G(X)),X=9999999-X ; produce an internal date
101 S SAVX=X
102 S X=$$FMTE^XLFDT(X,"5ZD") D ^%DT I Y=-1 S SAVX=$$NOW^XLFDT ; if not valid date, set to NOW
103 S X=SAVX
104 S X=$$FMADD^XLFDT(X,1,0,0,0) ; add one day so any GAF data entered today will appear on output
105 S X=$$FMTE^XLFDT(X,"5ZD") ; output in external format
106 Q X
107ETF(X) ; External to Fileman format
108 N %DT,Y S X=$G(X),%DT="PST" D ^%DT S X=Y S:+X'>0 X="" Q X
109TOM(X) ; Tomorrow
110 S X=$$FMTE^XLFDT($$FMADD^XLFDT($$NOW^XLFDT,1,0,0,0),"5ZD") Q X
111TOD(X) ; Today
112 S X=$$NOW^XLFDT Q X
113DEC(X) ; Deceased Date
114 N %,%H,%I,%X,%T,VA,VADM,VAERR,DFN S DFN=+($G(X)) Q:DFN=0 "" Q:'$D(^DPT(+DFN,0)) ""
115 D DEM^VADPT S X=+$G(VADM(6)) S:X=0 X="" Q X
116B(X,Y) ; Graph Bar
117 N GMTSGAF,GMTSCHAR,GMTSCW,GMTSLEN,GMTSI,GMTSBAR S GMTSGAF=$G(X),GMTSCW=+($G(Y)) Q:GMTSCW=0 ""
118 S GMTSCHAR="#" F Q:$E(GMTSGAF,1)'="0" S GMTSGAF=$E(GMTSGAF,2,$L(GMTSGAF))
119 S GMTSGAF=+GMTSGAF Q:GMTSGAF=0 ""
120 I GMTSGAF>99 S GMTSBAR="",$P(GMTSBAR,GMTSCHAR,GMTSCW)=GMTSCHAR
121 I GMTSGAF'>99 S GMTSI=GMTSCW/100,GMTSLEN=GMTSI*GMTSGAF,GMTSLEN=$FN(GMTSLEN,"",0),GMTSBAR="",$P(GMTSBAR,GMTSCHAR,GMTSLEN)=GMTSCHAR
122 S X=GMTSBAR Q X
123GAF(X) ; 2 Digit GAF Score
124 S X=$E($G(X),1,3) Q:X=""!(X="---") "" S X=+X Q:X=0 " 0" S:$L(X)=1 X=" "_X S:$L(X)=2 X=" "_X Q X
125DTM(X) ; Current Date and Time (External)
126 S X=$$NOW^XLFDT D REGDTM4^GMTSU Q X
Note: See TracBrowser for help on using the repository browser.