source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMGECN.m@ 619

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

initial load of WorldVistAEHR
File size: 5.7 KB
Line 
1PXRMGECN ;SLC/JVS GEC-Score Reports-cont'd ;06/01/2007
2 ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
3 Q
4SUM ;By Summary by Patient
5 N CAT,HF,DATE,DFN,Y,HFN,CNTREF,X,REFNUM,SUM,GSUM,CATDANA
6 N DATER,SDATE,SCNT
7 D E^PXRMGECV("HS1",1,BDT,EDT,"F",DFNONLY)
8 I FORMAT="D" S FOR=0
9 I FORMAT="F" S FOR=1
10 W @IOF
11 S CATDANA("GEC REFERRAL BASIC ADL")=""
12 S CATDANA("GEC REFERRAL IADL")=""
13 S CATDANA("GEC REFERRAL SKILLED CARE")=""
14 S CATDANA("GEC REFERRAL PATIENT BEHAVIORS/SYMPTOM")=""
15 ;
16 S Y=1,SUM=0,DATER=0,GSUM=0
17 S DFN="" F S DFN=$O(^TMP("PXRMGEC",$J,"HS1",DFN)) Q:DFN=""!(Y=0) D
18 .S CNTREF="",REFNUM=0 F S CNTREF=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF)) Q:CNTREF=""!(Y=0) D
19 ..S REFNUM=REFNUM+1
20 ..S SDATE=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,0)) D
21 ...S DATER=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,SDATE,0))
22 ..S DATE=0 F S DATE=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE)) Q:DATE=""!(Y=0) D
23 ...S VDT=0 F S VDT=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE,VDT)) Q:VDT=""!(Y=0) D
24 ....S CAT=0 F S CAT=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE,VDT,CAT)) Q:CAT=""!(Y=0) D
25 .....Q:'$D(CATDANA(CAT))
26 .....S SUM=0
27 .....S DATEV=0 F S DATEV=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE,VDT,CAT,DATEV)) Q:DATEV=""!(Y=0) D
28 ......S DA=0 F S DA=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE,VDT,CAT,DATEV,DA)) Q:DA=""!(Y=0) D
29 .......S HFN=$$HFNAME^PXRMGECR(DA)
30 .......S SUM=SUM+$$VALUE($P($G(^AUPNVHF(DA,0)),"^",1))
31 .......S CATSUM(CAT)=SUM
32 ..S GSUM=+$G(CATSUM("GEC REFERRAL IADL"))+(+$G(CATSUM("GEC REFERRAL BASIC ADL")))+(+$G(CATSUM("GEC REFERRAL SKILLED CARE")))+(+$G(CATSUM("GEC REFERRAL PATIENT BEHAVIORS/SYMPTOM")))
33 ..S ^TMP("PXRMGEC",$J,"S",DFN,SDATE,DATER,+$G(CATSUM("GEC REFERRAL IADL")),+$G(CATSUM("GEC REFERRAL BASIC ADL")),+$G(CATSUM("GEC REFERRAL SKILLED CARE")),+$G(CATSUM("GEC REFERRAL PATIENT BEHAVIORS/SYMPTOM")),GSUM)=""
34 ..K CATSUM
35 ;
36DIS ;Start of Display
37 S REF="^TMP(""PXRMGEC"",$J,""S"")"
38 W !,"=============================================================================="
39 W !,"GEC Patient-Summary (Score)"
40 W !,"Data on Complete Referrals Only"
41 W !,"From: "_$$FMTE^XLFDT(BDT,"5ZM")_" To: "_$$FMTE^XLFDT(EDT,"5ZM")
42 W !
43 I FOR W !,?33,"Finished",?49,"Basic",?55,"Skilled",?63,"Patient",?73,"TOTAL"
44 I FOR W !,"Name",?22,"SSN",?33,"Date",?44,"IADL",?49,"ADL",?55,"Care",?63,"Behaviors",?73,"ACROSS"
45 I 'FOR W !,"Name^SSN^Referral Date^IADL^Basic ADL^Skilled Care^Behaviors^Totals"
46 W !,"=============================================================================="
47 N S1,S2,S3,S4,S5,S1T,S2T,S3T,S4T,S5T
48 S (S1T,S2T,S3T,S4T,S5T,CNT)=0
49 S DFN="" F S DFN=$O(@REF@(DFN)) Q:DFN="" D
50 .S SDATE="" F S SDATE=$O(@REF@(DFN,SDATE)) Q:SDATE="" D
51 ..S DATER="" F S DATER=$O(@REF@(DFN,SDATE,DATER)) Q:DATER="" D
52 ...S CNT=CNT+1
53 ...S S1="" F S S1=$O(@REF@(DFN,SDATE,DATER,S1)) Q:S1="" D
54 ....S S1T=S1T+S1
55 ....S S2="" F S S2=$O(@REF@(DFN,SDATE,DATER,S1,S2)) Q:S2="" D
56 .....S S2T=S2T+S2
57 .....S S3="" F S S3=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3)) Q:S3="" D
58 ......S S3T=S3T+S3
59 ......S S4="" F S S4=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4)) Q:S4="" D
60 .......S S4T=S4T+S4
61 .......S S5="" F S S5=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4,S5)) Q:S5="" D
62 ........S S5T=S5T+S5
63 ........I FOR W !,$E($P(DFN," ",1,$L(DFN," ")-1),1,19),?20," ("_$P(DFN," ",$L(DFN," "))_")",?33,$P($$FMTE^XLFDT(DATER,"5ZM"),"@",1),?44,$J(S1,3),?49,$J(S2,3),?55,$J(S3,3),?63,$J(S4,3),?73,$J(S5,3)
64 ........D PB Q:Y=0
65 ........I 'FOR W !,$P(DFN," ",1,$L(DFN," ")-1),"^",$P(DFN," ",$L(DFN," ")),"^",$P($$FMTE^XLFDT(DATER,"5ZM"),"@",1),"^",S1,"^",S2,"^",S3,"^",S4,"^",S5
66 Q:CNT=0
67 I FOR W !,?44,"_________________________________" D PB Q:Y=0
68 I FOR W !,?33,"Totals > >",?44,$J(S1T,3),?49,$J(S2T,3),?55,$J(S3T,3),?63,$J(S4T,3),?72,$J(S5T,4) D PB Q:Y=0
69 I FOR W !,?34,"Means > >",?44,$J($FN(S1T/CNT,"",1),3),?49,$J($FN(S2T/CNT,"",1),3),?55,$J($FN(S3T/CNT,"",1),3),?63,$J($FN(S4T/CNT,"",1),3),?72,$J($FN(S5T/CNT,"",1),4)
70 D PB Q:Y=0
71 S (S1T,S2T,S3T,S4T,S5T,SCNT)=0
72 N S1TDEV,S1TDEVT,S2TDEV,S2TDEVT,S3TDEV,S3TDEVT,S4TDEV,S4TDEVT,S5TDEV,S5TDEVT
73 S (S1TDEVT,S2TDEVT,S3TDEVT,S4TDEVT,S5TDEVT)=0
74 S DFN="" F S DFN=$O(@REF@(DFN)) Q:DFN="" D
75 .S SDATE="" F S SDATE=$O(@REF@(DFN,SDATE)) Q:SDATE="" D
76 ..S DATER="" F S DATER=$O(@REF@(DFN,SDATE,DATER)) Q:DATER="" D
77 ...S S1="" F S S1=$O(@REF@(DFN,SDATE,DATER,S1)) Q:S1="" D
78 ....S S1TDEV=(S1-(S1T/CNT))*(S1-(S1T/CNT)) S S1TDEVT=S1TDEVT+S1TDEV
79 ....S S2="" F S S2=$O(@REF@(DFN,SDATE,DATER,S1,S2)) Q:S2="" D
80 .....S S2TDEV=(S2-(S2T/CNT))*(S2-(S2T/CNT)) S S2TDEVT=S2TDEVT+S2TDEV
81 .....S S3="" F S S3=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3)) Q:S3="" D
82 ......S S3TDEV=(S3-(S3T/CNT))*(S3-(S3T/CNT)) S S3TDEVT=S3TDEVT+S3TDEV
83 ......S S4="" F S S4=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4)) Q:S4="" D
84 .......S S4TDEV=(S4-(S4T/CNT))*(S4-(S4T/CNT)) S S4TDEVT=S4TDEVT+S4TDEV
85 .......S S5="" F S S5=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4,S5)) Q:S5="" D
86 ........S S5TDEV=(S5-(S5T/CNT))*(S5-(S5T/CNT)) S S5TDEVT=S5TDEVT+S5TDEV
87 I FOR W !,?20,"Standard Deviations > >"
88 I CNT<2 S CNT=CNT+1
89 I FOR W ?44,$J($FN($$SQROOT(S1TDEVT/(CNT-1)),"",1),3),?49,$J($FN($$SQROOT(S2TDEVT/(CNT-1)),"",1),3),?55,$J($FN($$SQROOT(S3TDEVT/(CNT-1)),"",1),3),?63,$J($FN($$SQROOT(S4TDEVT/(CNT-1)),"",1),3),?72,$J($FN($$SQROOT(S5TDEVT/(CNT-1)),"",1),4)
90 D PB Q:Y=0
91 W ! D PB Q:Y=0
92 K ^TMP("PXRMGEC",$J)
93 D KILL^%ZISS
94 Q
95 ;
96SQROOT(NUM) ;Calculat Square Root
97 N PREC,ROOT S ROOT=0 GOTO SQROOTX:NUM=0
98 S:NUM<0 NUM=-NUM S ROOT=$S(NUM>1:NUM\1,1:1/NUM)
99 S ROOT=$E(ROOT,1,$L(ROOT)+1\2) S:NUM'>1 ROOT=1/ROOT
100 F PREC=1:1:6 S ROOT=NUM/ROOT+ROOT*.5
101SQROOTX Q ROOT
102 ;
103VALUE(DA) ;Return value for score
104 N CAT,SYN,VALUE,PICE
105 S SYN=$P($G(^AUTTHF(DA,0)),"^",9)
106 Q:$E(SYN,5,5)'="F" VALUE
107 Q:SYN="" VALUE
108 Q:$E(SYN,5,5)="C" VALUE
109 S VALUE=$P(SYN," ",$L(SYN," "))
110 Q VALUE
111 ;
112 ;
113PB ;PAGE BREAK
114 S Y=""
115 I $Y=(IOSL-2) D
116 .K DIR
117 .S DIR(0)="E"
118 .D ^DIR
119 .I Y=1 W @IOF S $Y=0
120 K DIR
121 Q
122 ;
Note: See TracBrowser for help on using the repository browser.