- DIXC ;SFISC/GFT-DESCRIPTIVE STATS, CORRELATION MATRIX ;22APR2010
- ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- ;;Per VA Directive 6402, this routine should not be modified.
- ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- ;;Licensed under the terms of the Apache License, Version 2.0.
- ;
- N DIXSKIP,DJ S DIXSKIP=1,DJ=$P G DESCX
- D N SZ,SZT,DJ,DN,DHDR,DS,DIXSKIP
- D DESC G DESCX
- ;
- C D CORR G CORRX
- ;
- SQR S Y=0 Q:X'>0 S Y=1+X/2
- L S T=Y,Y=X/T+T/2 G L:Y<T
- K T Q
- ;
- DLCOR S DJ=IO(0),U="^",SZ=0
- F SZT=1:1 S:$D(^DOSV(0,DJ,"CP",SZT)) SZ=SZT Q:'$D(^DOSV(0,DJ,0,SZT,"S")) Q:'$D(^DOSV(0,DJ,"F",SZT)) S DN(SZT)=$E($P(^(SZT),U,3),1,8)
- S SZT=SZT-1 Q
- ;
- DESC ;CALCULATE THE DESCRIPTIVE STATISTICS
- D DLCOR K DS F I=1:1:SZT I $D(^DOSV(0,DJ,0,I,"Q")) S X=^("Q")-((^("S")*^("S"))/^("N"))/(^("N")) D SQR S ^("D")=Y
- Q
- ;
- DESCX ;PRINT DESCRIPTIVE STATS
- N DIXDELIM,DHDR,DIFF,%ZIS
- S:$D(^%ZTSK) %ZIS="Q" D ^%ZIS G Q:POP
- S DIFF=$D(^DOSV(0,DJ,1))!$D(^(2))!$D(^(3))
- I DIFF,$G(IOT)="HFS" W !,"USE COMMA AS DELIMITER FOR SPEADSHEET" S %=2 D YN^DICN G Q:%<1 S:%=1 DIXDELIM=","
- I $D(IO("Q")) D G KL
- .F I="DIFF","DIX*","^DOSV(0,$I,","SZT","DN*" S ZTSAVE(I)=""
- .S ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL,ZTRTN="DQ^DIXC"
- .D ^%ZTLOAD
- D1 I '$G(DIXSKIP),$D(SZT) S DHDR="77CUST",DHDR(1)="DESCRIPTIVE STATISTICS" D DQ^DIX D:SZT G KL:'DIFF
- .W !!,?13,"N OF",?39,"STANDARD"
- .W !,?13,"CASES",?25,"MEAN",?39,"DEVIATION",?54,"MINIMUM",?69,"MAXIMUM"
- .F I=1:1:SZT D
- ..W !,DN(I),?10
- ..I $D(^DOSV(0,DJ,0,I,"N")) W $J(^("N"),6) W:^("N") $J(^("S")/^("N"),15,4)
- ..F X="D","L","H" W $S($D(^(X)):$J(^(X),15,4),1:$J("",15))
- .D EOP^DIG Q
- D STATS^DIG($NA(^DOSV(0,DJ)),.DIXDELIM) Q
- ;
- CORR ;CALCULATE THE CORRELATION MATRIX
- K ^UTILITY($J),ERR I $O(^DOSV(0,IO(0),1))'>0 W !!,"***** AT LEAST TWO VARIABLES MUST BE DEFINED *****" S ERR=1 Q
- D DLCOR ;F I=1:1:SZ I ^DOSV(0,IO(0),"BY",I,"H")=^("L") W $C(7),!,"CAN'T COMPUTE CORRELATION MATRIX--",DN(I+100)," IS SINGLE-VALUED" S ERR=1 G KL
- F I=2:1:SZ S N=^DOSV(0,DJ,0,I,"N"),S=^("S"),C=^DOSV(0,DJ,"CP",I,I) F J=1:1:I-1 I $D(^DOSV(0,DJ,"CP",I,J)) D C1
- G KL
- C1 S X=N*C-(S*S)*(N*^DOSV(0,DJ,"CP",J,J))-(^DOSV(0,DJ,0,J,"S")*^("S"))
- D SQR S (^UTILITY($J,J,I),^UTILITY($J,I,J))=(N*^DOSV(0,DJ,"CP",I,J))-(S*^DOSV(0,DJ,0,J,"S"))/Y
- Q
- CORRX ;OUTPUT THE CORRELATION MATRIX
- G:$D(ERR) KL K DHDR S DHDR="72TSU",DHDR(1)="CORRELATION MATRIX",DHDR(2)="" D DHDR^DIX G Q:POP
- F I=1:1:SZ S ^UTILITY($J,I,I)=1 I $D(^UTILITY($J,I,I)) W ?I*10-2,$J(DN(I),10)
- F I=1:1:SZ I $D(^UTILITY($J,I,I)) W !,DN(I) F J=1:1:I I $D(^UTILITY($J,I,J)) W ?J*10,$J(^UTILITY($J,I,J),8,4)
- W !!
- KL W:$E(IOST)'="C"&($Y) @IOF I IO(0)'=IO D CLOSE^DIO4
- Q U $P K C,DHDR,I,II,J,JJ,N,POP,S,X,Y,Z,DJ,DN,SZ,SZT,DIFF
- Q
- ;
- ;
- DQ ;FOR QUEUED OUTPUT
- S DJ=$I G D1
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIXC 2875 printed Feb 19, 2025@00:21:17 Page 2
- DIXC ;SFISC/GFT-DESCRIPTIVE STATS, CORRELATION MATRIX ;22APR2010
- +1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- +4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- +5 ;;Licensed under the terms of the Apache License, Version 2.0.
- +6 ;
- +7 NEW DIXSKIP,DJ
- SET DIXSKIP=1
- SET DJ=$PRINCIPAL
- GOTO DESCX
- D NEW SZ,SZT,DJ,DN,DHDR,DS,DIXSKIP
- +1 DO DESC
- GOTO DESCX
- +2 ;
- C DO CORR
- GOTO CORRX
- +1 ;
- SQR SET Y=0
- if X'>0
- QUIT
- SET Y=1+X/2
- L SET T=Y
- SET Y=X/T+T/2
- if Y<T
- GOTO L
- +1 KILL T
- QUIT
- +2 ;
- DLCOR SET DJ=IO(0)
- SET U="^"
- SET SZ=0
- +1 FOR SZT=1:1
- if $DATA(^DOSV(0,DJ,"CP",SZT))
- SET SZ=SZT
- if '$DATA(^DOSV(0,DJ,0,SZT,"S"))
- QUIT
- if '$DATA(^DOSV(0,DJ,"F",SZT))
- QUIT
- SET DN(SZT)=$EXTRACT($PIECE(^(SZT),U,3),1,8)
- +2 SET SZT=SZT-1
- QUIT
- +3 ;
- DESC ;CALCULATE THE DESCRIPTIVE STATISTICS
- +1 DO DLCOR
- KILL DS
- FOR I=1:1:SZT
- IF $DATA(^DOSV(0,DJ,0,I,"Q"))
- SET X=^("Q")-((^("S")*^("S"))/^("N"))/(^("N"))
- DO SQR
- SET ^("D")=Y
- +2 QUIT
- +3 ;
- DESCX ;PRINT DESCRIPTIVE STATS
- +1 NEW DIXDELIM,DHDR,DIFF,%ZIS
- +2 if $DATA(^%ZTSK)
- SET %ZIS="Q"
- DO ^%ZIS
- if POP
- GOTO Q
- +3 SET DIFF=$DATA(^DOSV(0,DJ,1))!$DATA(^(2))!$DATA(^(3))
- +4 IF DIFF
- IF $GET(IOT)="HFS"
- WRITE !,"USE COMMA AS DELIMITER FOR SPEADSHEET"
- SET %=2
- DO YN^DICN
- if %<1
- GOTO Q
- if %=1
- SET DIXDELIM=","
- +5 IF $DATA(IO("Q"))
- Begin DoDot:1
- +6 FOR I="DIFF","DIX*","^DOSV(0,$I,","SZT","DN*"
- SET ZTSAVE(I)=""
- +7 SET ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL
- SET ZTRTN="DQ^DIXC"
- +8 DO ^%ZTLOAD
- End DoDot:1
- GOTO KL
- D1 IF '$GET(DIXSKIP)
- IF $DATA(SZT)
- SET DHDR="77CUST"
- SET DHDR(1)="DESCRIPTIVE STATISTICS"
- DO DQ^DIX
- if SZT
- Begin DoDot:1
- +1 WRITE !!,?13,"N OF",?39,"STANDARD"
- +2 WRITE !,?13,"CASES",?25,"MEAN",?39,"DEVIATION",?54,"MINIMUM",?69,"MAXIMUM"
- +3 FOR I=1:1:SZT
- Begin DoDot:2
- +4 WRITE !,DN(I),?10
- +5 IF $DATA(^DOSV(0,DJ,0,I,"N"))
- WRITE $JUSTIFY(^("N"),6)
- if ^("N")
- WRITE $JUSTIFY(^("S")/^("N"),15,4)
- +6 FOR X="D","L","H"
- WRITE $SELECT($DATA(^(X)):$JUSTIFY(^(X),15,4),1:$JUSTIFY("",15))
- End DoDot:2
- +7 DO EOP^DIG
- QUIT
- End DoDot:1
- if 'DIFF
- GOTO KL
- +8 DO STATS^DIG($NAME(^DOSV(0,DJ)),.DIXDELIM)
- QUIT
- +9 ;
- CORR ;CALCULATE THE CORRELATION MATRIX
- +1 KILL ^UTILITY($JOB),ERR
- IF $ORDER(^DOSV(0,IO(0),1))'>0
- WRITE !!,"***** AT LEAST TWO VARIABLES MUST BE DEFINED *****"
- SET ERR=1
- QUIT
- +2 ;F I=1:1:SZ I ^DOSV(0,IO(0),"BY",I,"H")=^("L") W $C(7),!,"CAN'T COMPUTE CORRELATION MATRIX--",DN(I+100)," IS SINGLE-VALUED" S ERR=1 G KL
- DO DLCOR
- +3 FOR I=2:1:SZ
- SET N=^DOSV(0,DJ,0,I,"N")
- SET S=^("S")
- SET C=^DOSV(0,DJ,"CP",I,I)
- FOR J=1:1:I-1
- IF $DATA(^DOSV(0,DJ,"CP",I,J))
- DO C1
- +4 GOTO KL
- C1 SET X=N*C-(S*S)*(N*^DOSV(0,DJ,"CP",J,J))-(^DOSV(0,DJ,0,J,"S")*^("S"))
- +1 DO SQR
- SET (^UTILITY($JOB,J,I),^UTILITY($JOB,I,J))=(N*^DOSV(0,DJ,"CP",I,J))-(S*^DOSV(0,DJ,0,J,"S"))/Y
- +2 QUIT
- CORRX ;OUTPUT THE CORRELATION MATRIX
- +1 if $DATA(ERR)
- GOTO KL
- KILL DHDR
- SET DHDR="72TSU"
- SET DHDR(1)="CORRELATION MATRIX"
- SET DHDR(2)=""
- DO DHDR^DIX
- if POP
- GOTO Q
- +2 FOR I=1:1:SZ
- SET ^UTILITY($JOB,I,I)=1
- IF $DATA(^UTILITY($JOB,I,I))
- WRITE ?I*10-2,$JUSTIFY(DN(I),10)
- +3 FOR I=1:1:SZ
- IF $DATA(^UTILITY($JOB,I,I))
- WRITE !,DN(I)
- FOR J=1:1:I
- IF $DATA(^UTILITY($JOB,I,J))
- WRITE ?J*10,$JUSTIFY(^UTILITY($JOB,I,J),8,4)
- +4 WRITE !!
- KL if $EXTRACT(IOST)'="C"&($Y)
- WRITE @IOF
- IF IO(0)'=IO
- DO CLOSE^DIO4
- Q USE $PRINCIPAL
- KILL C,DHDR,I,II,J,JJ,N,POP,S,X,Y,Z,DJ,DN,SZ,SZT,DIFF
- +1 QUIT
- +2 ;
- +3 ;
- DQ ;FOR QUEUED OUTPUT
- +1 SET DJ=$IO
- GOTO D1
