PXRMGECM ;SLC/JVS GEC-Score Reports-cont'd ;7/14/05 10:43
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
Q
SUM ;By Summary by Patient
N CAT,HF,DATE,DFN,Y,HFN,CNTREF,X,REFNUM,SUM,GSUM,CATDANA,PAGE
N DATER,SDATE,SCNT
D E^PXRMGECV("HS1",1,BDT,EDT,"F",DFNONLY)
I FORMAT="D" S FOR=0
I FORMAT="F" S FOR=1
W @IOF
S CATDANA("GEC REFERRAL BASIC ADL")=""
S CATDANA("GEC REFERRAL IADL")=""
S CATDANA("GEC REFERRAL SKILLED CARE")=""
S CATDANA("GEC REFERRAL PATIENT BEHAVIORS/SYMPTOM")=""
;
S Y=1,SUM=0,DATER=0,GSUM=0
S DFN="" F S DFN=$O(^TMP("PXRMGEC",$J,"HS1",DFN)) Q:DFN=""!(Y=0) D
.S CNTREF="",REFNUM=0 F S CNTREF=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF)) Q:CNTREF=""!(Y=0) D
..S REFNUM=REFNUM+1
..S SDATE=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,0)) D
...S DATER=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,SDATE,0))
..S DATE=0 F S DATE=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE)) Q:DATE=""!(Y=0) D
...S VDT=0 F S VDT=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE,VDT)) Q:VDT=""!(Y=0) D
....S CAT=0 F S CAT=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE,VDT,CAT)) Q:CAT=""!(Y=0) D
.....Q:'$D(CATDANA(CAT))
.....S SUM=0
.....S DATEV=0 F S DATEV=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE,VDT,CAT,DATEV)) Q:DATEV=""!(Y=0) D
......S DA=0 F S DA=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE,VDT,CAT,DATEV,DA)) Q:DA=""!(Y=0) D
.......S HFN=$$HFNAME^PXRMGECR(DA)
.......S SUM=SUM+$$VALUE($P($G(^AUPNVHF(DA,0)),"^",1))
.......S CATSUM(CAT)=SUM
..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")))
..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)=""
..K CATSUM
;
DIS ;Start of Display
S REF="^TMP(""PXRMGEC"",$J,""S"")"
W !,"=============================================================================="
W !,"GEC Patient-Summary (Score)"
W !,"Data on Complete Referrals Only"
W !,"From: "_$$FMTE^XLFDT(BDT,"5ZM")_" To: "_$$FMTE^XLFDT(EDT,"5ZM")
W !
I FOR W !,?33,"Finished",?49,"Basic",?55,"Skilled",?63,"Patient",?73,"TOTAL"
I FOR W !,"Name",?22,"SSN",?33,"Date",?44,"IADL",?49,"ADL",?55,"Care",?63,"Behaviors",?73,"ACROSS"
I 'FOR W !,"Name^SSN^Referral Date^IADL^Basic ADL^Skilled Care^Behaviors^Totals"
W !,"=============================================================================="
S PAGE=1
N S1,S2,S3,S4,S5,S1T,S2T,S3T,S4T,S5T
S (S1T,S2T,S3T,S4T,S5T,CNT)=0
S DFN="" F S DFN=$O(@REF@(DFN)) Q:DFN="" D
.S SDATE="" F S SDATE=$O(@REF@(DFN,SDATE)) Q:SDATE="" D
..S DATER="" F S DATER=$O(@REF@(DFN,SDATE,DATER)) Q:DATER="" D
...S CNT=CNT+1
...S S1="" F S S1=$O(@REF@(DFN,SDATE,DATER,S1)) Q:S1="" D
....S S1T=S1T+S1
....S S2="" F S S2=$O(@REF@(DFN,SDATE,DATER,S1,S2)) Q:S2="" D
.....S S2T=S2T+S2
.....S S3="" F S S3=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3)) Q:S3="" D
......S S3T=S3T+S3
......S S4="" F S S4=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4)) Q:S4="" D
.......S S4T=S4T+S4
.......S S5="" F S S5=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4,S5)) Q:S5="" D
........S S5T=S5T+S5
........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) D PAGE^PXRMGECZ
........I 'FOR W !,$P(DFN," ",1,$L(DFN," ")-1),"^",$P(DFN," ",$L(DFN," ")),"^",$P($$FMTE^XLFDT(DATER,"5ZM"),"@",1),"^",S1,"^",S2,"^",S3,"^",S4,"^",S5 D PAGE^PXRMGECZ
Q:CNT=0
I FOR W !,?44,"_________________________________" D PAGE^PXRMGECZ
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 PAGE^PXRMGECZ
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) D PAGE^PXRMGECZ
S (S1T,S2T,S3T,S4T,S5T,SCNT)=0
N S1TDEV,S1TDEVT,S2TDEV,S2TDEVT,S3TDEV,S3TDEVT,S4TDEV,S4TDEVT,S5TDEV,S5TDEVT
S (S1TDEVT,S2TDEVT,S3TDEVT,S4TDEVT,S5TDEVT)=0
S DFN="" F S DFN=$O(@REF@(DFN)) Q:DFN="" D
.S SDATE="" F S SDATE=$O(@REF@(DFN,SDATE)) Q:SDATE="" D
..S DATER="" F S DATER=$O(@REF@(DFN,SDATE,DATER)) Q:DATER="" D
...S S1="" F S S1=$O(@REF@(DFN,SDATE,DATER,S1)) Q:S1="" D
....S S1TDEV=(S1-(S1T/CNT))*(S1-(S1T/CNT)) S S1TDEVT=S1TDEVT+S1TDEV
....S S2="" F S S2=$O(@REF@(DFN,SDATE,DATER,S1,S2)) Q:S2="" D
.....S S2TDEV=(S2-(S2T/CNT))*(S2-(S2T/CNT)) S S2TDEVT=S2TDEVT+S2TDEV
.....S S3="" F S S3=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3)) Q:S3="" D
......S S3TDEV=(S3-(S3T/CNT))*(S3-(S3T/CNT)) S S3TDEVT=S3TDEVT+S3TDEV
......S S4="" F S S4=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4)) Q:S4="" D
.......S S4TDEV=(S4-(S4T/CNT))*(S4-(S4T/CNT)) S S4TDEVT=S4TDEVT+S4TDEV
.......S S5="" F S S5=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4,S5)) Q:S5="" D
........S S5TDEV=(S5-(S5T/CNT))*(S5-(S5T/CNT)) S S5TDEVT=S5TDEVT+S5TDEV
I FOR W !,?20,"Standard Deviations > >"
I CNT<2 S CNT=CNT+1
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)
I FOR W ?72,$J($FN($$SQROOT(S5TDEVT/(CNT-1)),"",1),4) D PAGE^PXRMGECZ
K ^TMP("PXRMGEC",$J)
D KILL^%ZISS
Q
;
SQROOT(NUM) ;Calculat Square Root
N PREC,ROOT S ROOT=0 GOTO SQROOTX:NUM=0
S:NUM<0 NUM=-NUM S ROOT=$S(NUM>1:NUM\1,1:1/NUM)
S ROOT=$E(ROOT,1,$L(ROOT)+1\2) S:NUM'>1 ROOT=1/ROOT
F PREC=1:1:6 S ROOT=NUM/ROOT+ROOT*.5
SQROOTX Q ROOT
;
VALUE(DA) ;Return value for score
N CAT,SYN,VALUE,PICE
S SYN=$P($G(^AUTTHF(DA,0)),"^",9)
Q:$E(SYN,5,5)'="F" VALUE
Q:SYN="" VALUE
Q:$E(SYN,5,5)="C" VALUE
S VALUE=$P(SYN," ",$L(SYN," "))
Q VALUE
;
;
PXRMGECM ;SLC/JVS GEC-Score Reports-cont'd ;7/14/05 10:43
+1 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+2 QUIT
SUM ;By Summary by Patient
+1 NEW CAT,HF,DATE,DFN,Y,HFN,CNTREF,X,REFNUM,SUM,GSUM,CATDANA,PAGE
+2 NEW DATER,SDATE,SCNT
+3 DO E^PXRMGECV("HS1",1,BDT,EDT,"F",DFNONLY)
+4 IF FORMAT="D"
SET FOR=0
+5 IF FORMAT="F"
SET FOR=1
+6 WRITE @IOF
+7 SET CATDANA("GEC REFERRAL BASIC ADL")=""
+8 SET CATDANA("GEC REFERRAL IADL")=""
+9 SET CATDANA("GEC REFERRAL SKILLED CARE")=""
+10 SET CATDANA("GEC REFERRAL PATIENT BEHAVIORS/SYMPTOM")=""
+11 ;
+12 SET Y=1
SET SUM=0
SET DATER=0
SET GSUM=0
+13 SET DFN=""
FOR
SET DFN=$ORDER(^TMP("PXRMGEC",$JOB,"HS1",DFN))
IF DFN=""!(Y=0)
QUIT
Begin DoDot:1
+14 SET CNTREF=""
SET REFNUM=0
FOR
SET CNTREF=$ORDER(^TMP("PXRMGEC",$JOB,"HS1",DFN,CNTREF))
IF CNTREF=""!(Y=0)
QUIT
Begin DoDot:2
+15 SET REFNUM=REFNUM+1
+16 SET SDATE=$ORDER(^TMP("PXRMGEC",$JOB,"HS1",DFN,CNTREF,0))
Begin DoDot:3
+17 SET DATER=$ORDER(^TMP("PXRMGEC",$JOB,"HS1",DFN,CNTREF,SDATE,0))
End DoDot:3
+18 SET DATE=0
FOR
SET DATE=$ORDER(^TMP("PXRMGEC",$JOB,"HS1",DFN,CNTREF,DATE))
IF DATE=""!(Y=0)
QUIT
Begin DoDot:3
+19 SET VDT=0
FOR
SET VDT=$ORDER(^TMP("PXRMGEC",$JOB,"HS1",DFN,CNTREF,DATE,VDT))
IF VDT=""!(Y=0)
QUIT
Begin DoDot:4
+20 SET CAT=0
FOR
SET CAT=$ORDER(^TMP("PXRMGEC",$JOB,"HS1",DFN,CNTREF,DATE,VDT,CAT))
IF CAT=""!(Y=0)
QUIT
Begin DoDot:5
+21 IF '$DATA(CATDANA(CAT))
QUIT
+22 SET SUM=0
+23 SET DATEV=0
FOR
SET DATEV=$ORDER(^TMP("PXRMGEC",$JOB,"HS1",DFN,CNTREF,DATE,VDT,CAT,DATEV))
IF DATEV=""!(Y=0)
QUIT
Begin DoDot:6
+24 SET DA=0
FOR
SET DA=$ORDER(^TMP("PXRMGEC",$JOB,"HS1",DFN,CNTREF,DATE,VDT,CAT,DATEV,DA))
IF DA=""!(Y=0)
QUIT
Begin DoDot:7
+25 SET HFN=$$HFNAME^PXRMGECR(DA)
+26 SET SUM=SUM+$$VALUE($PIECE($GET(^AUPNVHF(DA,0)),"^",1))
+27 SET CATSUM(CAT)=SUM
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
+28 SET GSUM=+$GET(CATSUM("GEC REFERRAL IADL"))+(+$GET(CATSUM("GEC REFERRAL BASIC ADL")))+(+$GET(CATSUM("GEC REFERRAL SKILLED CARE")))+(+$GET(CATSUM("GEC REFERRAL PATIENT BEHAVIORS/SYMPTOM")))
+29 SET ^TMP("PXRMGEC",$JOB,"S",DFN,SDATE,DATER,+$GET(CATSUM("GEC REFERRAL IADL")),+$GET(CATSUM("GEC REFERRAL BASIC ADL")),+$GET(CATSUM("GEC REFERRAL SKILLED CARE")),+$GET(CATSUM("GEC REFERRAL PATIENT BEHAVIORS/SYMPTOM")),GSUM)=""
+30 KILL CATSUM
End DoDot:2
End DoDot:1
+31 ;
DIS ;Start of Display
+1 SET REF="^TMP(""PXRMGEC"",$J,""S"")"
+2 WRITE !,"=============================================================================="
+3 WRITE !,"GEC Patient-Summary (Score)"
+4 WRITE !,"Data on Complete Referrals Only"
+5 WRITE !,"From: "_$$FMTE^XLFDT(BDT,"5ZM")_" To: "_$$FMTE^XLFDT(EDT,"5ZM")
+6 WRITE !
+7 IF FOR
WRITE !,?33,"Finished",?49,"Basic",?55,"Skilled",?63,"Patient",?73,"TOTAL"
+8 IF FOR
WRITE !,"Name",?22,"SSN",?33,"Date",?44,"IADL",?49,"ADL",?55,"Care",?63,"Behaviors",?73,"ACROSS"
+9 IF 'FOR
WRITE !,"Name^SSN^Referral Date^IADL^Basic ADL^Skilled Care^Behaviors^Totals"
+10 WRITE !,"=============================================================================="
+11 SET PAGE=1
+12 NEW S1,S2,S3,S4,S5,S1T,S2T,S3T,S4T,S5T
+13 SET (S1T,S2T,S3T,S4T,S5T,CNT)=0
+14 SET DFN=""
FOR
SET DFN=$ORDER(@REF@(DFN))
IF DFN=""
QUIT
Begin DoDot:1
+15 SET SDATE=""
FOR
SET SDATE=$ORDER(@REF@(DFN,SDATE))
IF SDATE=""
QUIT
Begin DoDot:2
+16 SET DATER=""
FOR
SET DATER=$ORDER(@REF@(DFN,SDATE,DATER))
IF DATER=""
QUIT
Begin DoDot:3
+17 SET CNT=CNT+1
+18 SET S1=""
FOR
SET S1=$ORDER(@REF@(DFN,SDATE,DATER,S1))
IF S1=""
QUIT
Begin DoDot:4
+19 SET S1T=S1T+S1
+20 SET S2=""
FOR
SET S2=$ORDER(@REF@(DFN,SDATE,DATER,S1,S2))
IF S2=""
QUIT
Begin DoDot:5
+21 SET S2T=S2T+S2
+22 SET S3=""
FOR
SET S3=$ORDER(@REF@(DFN,SDATE,DATER,S1,S2,S3))
IF S3=""
QUIT
Begin DoDot:6
+23 SET S3T=S3T+S3
+24 SET S4=""
FOR
SET S4=$ORDER(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4))
IF S4=""
QUIT
Begin DoDot:7
+25 SET S4T=S4T+S4
+26 SET S5=""
FOR
SET S5=$ORDER(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4,S5))
IF S5=""
QUIT
Begin DoDot:8
+27 SET S5T=S5T+S5
+28 IF FOR
WRITE !,$EXTRACT($PIECE(DFN," ",1,$LENGTH(DFN," ")-1),1,19),?20," ("_$PIECE(DFN," ",$LENGTH(DFN," "))_")",?33,$PIECE($$FMTE^XLFDT(DATER,"5ZM"),"@",1),?44,$JUSTIFY(S1,3),?49,$JU
STIFY(S2,3),?55,$JUSTIFY(S3,3),?63,$JUSTIFY(S4,3),?73,$JUSTIFY(S5,3)
DO PAGE^PXRMGECZ
+29 IF 'FOR
WRITE !,$PIECE(DFN," ",1,$LENGTH(DFN," ")-1),"^",$PIECE(DFN," ",$LENGTH(DFN," ")),"^",$PIECE($$FMTE^XLFDT(DATER,"5ZM"),"@",1),"^",S1,"^",S2,"^",S3,"^",S4,"^",S5
DO PAGE^PXRMGECZ
End DoDot:8
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+30 IF CNT=0
QUIT
+31 IF FOR
WRITE !,?44,"_________________________________"
DO PAGE^PXRMGECZ
+32 IF FOR
WRITE !,?33,"Totals > >",?44,$JUSTIFY(S1T,3),?49,$JUSTIFY(S2T,3),?55,$JUSTIFY(S3T,3),?63,$JUSTIFY(S4T,3),?72,$JUSTIFY(S5T,4)
DO PAGE^PXRMGECZ
+33 IF FOR
WRITE !,?34,"Means > >",?44,$JUSTIFY($FNUMBER(S1T/CNT,"",1),3),?49,$JUSTIFY($FNUMBER(S2T/CNT,"",1),3),?55,$JUSTIFY($FNUMBER(S3T/CNT,"",1),3),?63,$JUSTIFY($FNUMBER(S4T/CNT,"",1),3),?72,$JUSTIFY($FNUMBER(S5T/CNT,"",1),4)
DO PAGE^PXRMGECZ
+34 SET (S1T,S2T,S3T,S4T,S5T,SCNT)=0
+35 NEW S1TDEV,S1TDEVT,S2TDEV,S2TDEVT,S3TDEV,S3TDEVT,S4TDEV,S4TDEVT,S5TDEV,S5TDEVT
+36 SET (S1TDEVT,S2TDEVT,S3TDEVT,S4TDEVT,S5TDEVT)=0
+37 SET DFN=""
FOR
SET DFN=$ORDER(@REF@(DFN))
IF DFN=""
QUIT
Begin DoDot:1
+38 SET SDATE=""
FOR
SET SDATE=$ORDER(@REF@(DFN,SDATE))
IF SDATE=""
QUIT
Begin DoDot:2
+39 SET DATER=""
FOR
SET DATER=$ORDER(@REF@(DFN,SDATE,DATER))
IF DATER=""
QUIT
Begin DoDot:3
+40 SET S1=""
FOR
SET S1=$ORDER(@REF@(DFN,SDATE,DATER,S1))
IF S1=""
QUIT
Begin DoDot:4
+41 SET S1TDEV=(S1-(S1T/CNT))*(S1-(S1T/CNT))
SET S1TDEVT=S1TDEVT+S1TDEV
+42 SET S2=""
FOR
SET S2=$ORDER(@REF@(DFN,SDATE,DATER,S1,S2))
IF S2=""
QUIT
Begin DoDot:5
+43 SET S2TDEV=(S2-(S2T/CNT))*(S2-(S2T/CNT))
SET S2TDEVT=S2TDEVT+S2TDEV
+44 SET S3=""
FOR
SET S3=$ORDER(@REF@(DFN,SDATE,DATER,S1,S2,S3))
IF S3=""
QUIT
Begin DoDot:6
+45 SET S3TDEV=(S3-(S3T/CNT))*(S3-(S3T/CNT))
SET S3TDEVT=S3TDEVT+S3TDEV
+46 SET S4=""
FOR
SET S4=$ORDER(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4))
IF S4=""
QUIT
Begin DoDot:7
+47 SET S4TDEV=(S4-(S4T/CNT))*(S4-(S4T/CNT))
SET S4TDEVT=S4TDEVT+S4TDEV
+48 SET S5=""
FOR
SET S5=$ORDER(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4,S5))
IF S5=""
QUIT
Begin DoDot:8
+49 SET S5TDEV=(S5-(S5T/CNT))*(S5-(S5T/CNT))
SET S5TDEVT=S5TDEVT+S5TDEV
End DoDot:8
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+50 IF FOR
WRITE !,?20,"Standard Deviations > >"
+51 IF CNT<2
SET CNT=CNT+1
+52 IF FOR
WRITE ?44,$JUSTIFY($FNUMBER($$SQROOT(S1TDEVT/(CNT-1)),"",1),3),?49,$JUSTIFY($FNUMBER($$SQROOT(S2TDEVT/(CNT-1)),"",1),3),?55,$JUSTIFY($FNUMBER($$SQROOT(S3TDEVT/(CNT-1)),"",1),3),?63,$JUSTIFY($FNUMBER($$SQROOT(S4TDEVT/(CNT-1)),"",1),3)
+53 IF FOR
WRITE ?72,$JUSTIFY($FNUMBER($$SQROOT(S5TDEVT/(CNT-1)),"",1),4)
DO PAGE^PXRMGECZ
+54 KILL ^TMP("PXRMGEC",$JOB)
+55 DO KILL^%ZISS
+56 QUIT
+57 ;
SQROOT(NUM) ;Calculat Square Root
+1 NEW PREC,ROOT
SET ROOT=0
IF NUM=0
GOTO SQROOTX
+2 IF NUM<0
SET NUM=-NUM
SET ROOT=$SELECT(NUM>1:NUM\1,1:1/NUM)
+3 SET ROOT=$EXTRACT(ROOT,1,$LENGTH(ROOT)+1\2)
IF NUM'>1
SET ROOT=1/ROOT
+4 FOR PREC=1:1:6
SET ROOT=NUM/ROOT+ROOT*.5
SQROOTX QUIT ROOT
+1 ;
VALUE(DA) ;Return value for score
+1 NEW CAT,SYN,VALUE,PICE
+2 SET SYN=$PIECE($GET(^AUTTHF(DA,0)),"^",9)
+3 IF $EXTRACT(SYN,5,5)'="F"
QUIT VALUE
+4 IF SYN=""
QUIT VALUE
+5 IF $EXTRACT(SYN,5,5)="C"
QUIT VALUE
+6 SET VALUE=$PIECE(SYN," ",$LENGTH(SYN," "))
+7 QUIT VALUE
+8 ;
+9 ;
