Changeset 623 for WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMGECN.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMGECN.m
r613 r623 1 PXRMGECN ;SLC/JVS GEC-Score Reports-cont'd ;06/01/20072 ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 3 4 SUM 5 6 N DATER,SDATE,SCNT 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 DIS 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 SQROOT(NUM) 97 98 99 100 101 SQROOTX 102 103 VALUE(DA) 104 105 106 107 108 109 110 111 112 113 PB 114 115 116 117 118 119 120 121 122 1 PXRMGECN ;SLC/JVS GEC-Score Reports-cont'd ;6/19/03 20:58 2 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005 3 Q 4 SUM ;By Summary by Patient 5 N CAT,HF,DATE,DFN,Y,HFN,CNTREF,X,REFNUM,SUM,GSUM,CATDANA 6 N DATER,SDATE 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 ; 36 DIS ;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 ; 96 SQROOT(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 101 SQROOTX Q ROOT 102 ; 103 VALUE(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 ; 113 PB ;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 TracChangeset
for help on using the changeset viewer.
