FHASN71 ; HISC/NCA - Print Status Average (cont.) ;9/28/95 10:52
;;5.5;DIETETICS;;Jan 28, 2005
Q0 ; Process Screening all patients
K S,DWRD S TOT=""
F WRD=0:0 S WRD=$O(^FH(119.6,WRD)) Q:WRD<1 F LST=0:0 S LST=$O(^FH(119.6,WRD,"W",LST)) Q:LST<1 S X=+$G(^(LST,0)) S:'$D(DWRD(X)) DWRD(X)=WRD
F FHDFN=0:0 S FHDFN=$O(^FHPT(FHDFN)) Q:FHDFN<1 I $D(^FHPT(FHDFN,0)) K N S ND=0 D Q1,CALC
G P0
Q1 ; Tabulate status
D PATNAME^FHOMUTL I DFN="" Q
S DGT=EDT+1,DGT=DGT+.0000001,(DGA1,DG1,DGXFR0)="" D ^DGPMSTAT Q:DGA1=""!(DG1="")
S ADM=DGA1,XX=$G(^DGPM(ADM,0)),DISC=$P(XX,"^",17) S:DISC'="" DISC=$P($G(^DGPM(DISC,0)),"^",1)
Q:'$D(^FHPT(FHDFN,"A",ADM,0))
S MW1=$S($P(DG1,"^",1):$P(DG1,"^",1),1:0),W1=$S($D(DWRD(+MW1)):$G(DWRD(+MW1)),1:0)
I '$D(^FH(119.6,+W1,0)) S MWRD=$P($G(^DIC(42,+MW1,0)),"^",1) S DW1=$O(^FH(119.6,"B",MWRD,0)) Q:DW1<1 S W1=+DW1
S WD=$P($G(^FH(119.6,+W1,0)),"^",2) S:'WD WD=0
I '$D(^FHPT(FHDFN,"S",0)) D Q2 Q
D NS I '$D(^TMP($J,"FHNS")) D Q2 Q
S NX="" F X4=0:0 S X4=$O(^TMP($J,"FHNS",X4)) Q:X4<1 S X5=$G(^(X4,0)),NX=X4 D CHK
Q
CHK ; Check if inpat with ADM
I $P(X5,"^",1)<$S($D(^FHPT(FHDFN,"A",ADM,0)):$P(^(0),"^",1),1:9999999) D GADM G:'$D(^FHPT(FHDFN,"A",ADM,0)) Q2 G:$P(X5,"^",1)<$S($D(^FHPT(FHDFN,"A",ADM,0)):$P(^(0),"^",1),1:9999999) Q2
I DISC,$P(X5,"^",1)>DISC D GADM Q:'$D(^FHPT(FHDFN,"A",ADM,0)) Q:DISC&($P(X5,"^",1)>DISC)
S S1=$P(X5,"^",2),D1=$P(X5,"^",3)
S W1=$S($P(X5,"^",6)'="":$P(X5,"^",6),1:W1) S:'W1 W1=0 S WD=$P($G(^FH(119.6,+W1,0)),"^",2) S:'WD WD=0
I S1,S1<5 G Q3
Q2 ; Unclassified
S S1=5,D1=WD
Q3 ; Set Classification
S X=$S(SRT="W":W1,1:D1) S:'$D(N(X)) N(X)="" S $P(N(X),"^",S1)=$P(N(X),"^",S1)+1,ND=ND+1
Q
GADM ; Get next ADM for pat
D PATNAME^FHOMUTL I DFN="" Q
S NX=$O(^DGPM("ATID1",DFN,NX)) Q:NX="" S ADM=+$O(^(NX,0)),XX=$G(^DGPM(ADM,0)),DISC=$P(XX,"^",17) S:DISC'="" DISC=$P($G(^DGPM(DISC,0)),"^",1)
Q:'$D(^FHPT(FHDFN,"A",ADM,0)) Q:$P(X5,"^",1)<$S($D(^FHPT(FHDFN,"A",ADM,0)):$P(^(0),"^",1),1:9999999)
S W1=$S($P(XX,"^",6):$P(XX,"^",6),1:0),WD=$P($G(^FH(119.6,+W1,0)),"^",2) S:'WD WD=0
Q
NS ; Nutrition Status in inverse date order
K ^TMP($J,"FHNS") S FHX1=9999999-(EDT+.3),FHX2=9999999-(SDT+.0001),ZZ=""
F XX=FHX1:0 S XX=$O(^FHPT(FHDFN,"S",XX)) Q:XX<1!(XX>FHX2) S X=$G(^(XX,0)) D STOR
I '$D(^TMP($J,"FHNS")) S XX=FHX1,FHX1=$O(^FHPT(FHDFN,"S",FHX1)) Q:FHX1="" S X=$G(^(FHX1,0)) D STOR
Q
STOR ; Store Nutrition Status by inverse date
I ZZ'=($P(X,"^",1)\1) S ^TMP($J,"FHNS",XX,0)=X
S ZZ=$P(X,"^",1)\1
Q
CALC ; Calculate Average
I $G(N(0))'="" S L=0 D C1
F L=0:0 S L=$O(N(L)) Q:L<1 D C1
Q
C1 F K=1:1:5 D
.S X=$S(ND:$P(N(L),"^",K)/ND,1:"")
.S X=$J(X,0,0) S:'$D(S(L)) S(L)=""
.S $P(S(L),"^",K)=$P(S(L),"^",K)+X
.S $P(S(L),"^",6)=$P(S(L),"^",6)+X
.S $P(TOT,"^",K)=$P(TOT,"^",K)+X
.S $P(TOT,"^",6)=$P(TOT,"^",6)+X
.Q
Q
P0 ; Print summary
S DTP=SDT D DTP^FH S DTE=DTP_" to " S DTP=EDT D DTP^FH S DTE=DTE_DTP
D NOW^%DTC S (NOW,DTP)=% D DTP^FH S PG=0,LN="",$P(LN,"-",100)="" D HDR
K ^TMP($J) F W1=0:0 S W1=$O(S(W1)) Q:W1="" D P1
S NAM="" F W1=0:0 S NAM=$O(^TMP($J,NAM)) Q:NAM="" S D1=^(NAM) D P2
I $G(S(0))'="" S D1=$G(S(0)) W ! D
.W ?16,"UNKNOWN",?48
.F K=1:1:5 S X=$P(D1,"^",K) W $S(X:$J(X,7),1:$J("",7)) S X=$S($P(D1,"^",6):X/$P(D1,"^",6)*100,1:"") W $S(X:$J(X,5,0),1:$J("",5))
.S X=$P(D1,"^",6) W $S(X:$J(X,7),1:$J("",7)) Q
W !?16,LN,!?16,"Grand Total",?48 F K=1:1:5 S X=$P(TOT,"^",K) W $S(X:$J(X,7),1:$J("",7)) S X=$S($P(TOT,"^",6):X/$P(TOT,"^",6)*100,1:"") W $S(X:$J(X,5,0),1:$J("",5))
S X=$P(TOT,"^",6) W $S(X:$J(X,7),1:$J("",7))
W ! Q
P1 I SRT="W" S NAM=$P($G(^FH(119.6,+W1,0)),"^",1)
E S NAM=$P($G(^VA(200,+W1,0)),"^",1)
Q:NAM="" S ^TMP($J,NAM_"~"_W1)=S(W1) Q
P2 D:$Y>(IOSL-8) HDR W !?16,$P(NAM,"~",1),?48
F K=1:1:5 S X=$P(D1,"^",K) W $S(X:$J(X,7),1:$J("",7)) S X=$S($P(D1,"^",6):X/$P(D1,"^",6)*100,1:"") W $S(X:$J(X,5,0),1:$J("",5))
S X=$P(D1,"^",6) W $S(X:$J(X,7),1:$J("",7))
Q
HDR W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 W !?16,DTP,!!?42,"N U T R I T I O N S T A T U S A V E R A G E",?109,"Page ",PG
W !!?(132-$L(DTE)\2),DTE
W !!?16,$S(SRT="C":"CLINICIAN",1:"WARD"),?54,"I % II % III % IV % UNC % TOTAL",!?16,LN,! Q
FHASN71 ; HISC/NCA - Print Status Average (cont.) ;9/28/95 10:52
+1 ;;5.5;DIETETICS;;Jan 28, 2005
Q0 ; Process Screening all patients
+1 KILL S,DWRD
SET TOT=""
+2 FOR WRD=0:0
SET WRD=$ORDER(^FH(119.6,WRD))
IF WRD<1
QUIT
FOR LST=0:0
SET LST=$ORDER(^FH(119.6,WRD,"W",LST))
IF LST<1
QUIT
SET X=+$GET(^(LST,0))
IF '$DATA(DWRD(X))
SET DWRD(X)=WRD
+3 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT(FHDFN))
IF FHDFN<1
QUIT
IF $DATA(^FHPT(FHDFN,0))
KILL N
SET ND=0
DO Q1
DO CALC
+4 GOTO P0
Q1 ; Tabulate status
+1 DO PATNAME^FHOMUTL
IF DFN=""
QUIT
+2 SET DGT=EDT+1
SET DGT=DGT+.0000001
SET (DGA1,DG1,DGXFR0)=""
DO ^DGPMSTAT
IF DGA1=""!(DG1="")
QUIT
+3 SET ADM=DGA1
SET XX=$GET(^DGPM(ADM,0))
SET DISC=$PIECE(XX,"^",17)
IF DISC'=""
SET DISC=$PIECE($GET(^DGPM(DISC,0)),"^",1)
+4 IF '$DATA(^FHPT(FHDFN,"A",ADM,0))
QUIT
+5 SET MW1=$SELECT($PIECE(DG1,"^",1):$PIECE(DG1,"^",1),1:0)
SET W1=$SELECT($DATA(DWRD(+MW1)):$GET(DWRD(+MW1)),1:0)
+6 IF '$DATA(^FH(119.6,+W1,0))
SET MWRD=$PIECE($GET(^DIC(42,+MW1,0)),"^",1)
SET DW1=$ORDER(^FH(119.6,"B",MWRD,0))
IF DW1<1
QUIT
SET W1=+DW1
+7 SET WD=$PIECE($GET(^FH(119.6,+W1,0)),"^",2)
IF 'WD
SET WD=0
+8 IF '$DATA(^FHPT(FHDFN,"S",0))
DO Q2
QUIT
+9 DO NS
IF '$DATA(^TMP($JOB,"FHNS"))
DO Q2
QUIT
+10 SET NX=""
FOR X4=0:0
SET X4=$ORDER(^TMP($JOB,"FHNS",X4))
IF X4<1
QUIT
SET X5=$GET(^(X4,0))
SET NX=X4
DO CHK
+11 QUIT
CHK ; Check if inpat with ADM
+1 IF $PIECE(X5,"^",1)<$SELECT($DATA(^FHPT(FHDFN,"A",ADM,0)):$PIECE(^(0),"^",1),1:9999999)
DO GADM
IF '$DATA(^FHPT(FHDFN,"A",ADM,0))
GOTO Q2
IF $PIECE(X5,"^",1)<$SELECT($DATA(^FHPT(FHDFN,"A",ADM,0))
GOTO Q2
+2 IF DISC
IF $PIECE(X5,"^",1)>DISC
DO GADM
IF '$DATA(^FHPT(FHDFN,"A",ADM,0))
QUIT
IF DISC&($PIECE(X5,"^",1)>DISC)
QUIT
+3 SET S1=$PIECE(X5,"^",2)
SET D1=$PIECE(X5,"^",3)
+4 SET W1=$SELECT($PIECE(X5,"^",6)'="":$PIECE(X5,"^",6),1:W1)
IF 'W1
SET W1=0
SET WD=$PIECE($GET(^FH(119.6,+W1,0)),"^",2)
IF 'WD
SET WD=0
+5 IF S1
IF S1<5
GOTO Q3
Q2 ; Unclassified
+1 SET S1=5
SET D1=WD
Q3 ; Set Classification
+1 SET X=$SELECT(SRT="W":W1,1:D1)
IF '$DATA(N(X))
SET N(X)=""
SET $PIECE(N(X),"^",S1)=$PIECE(N(X),"^",S1)+1
SET ND=ND+1
+2 QUIT
GADM ; Get next ADM for pat
+1 DO PATNAME^FHOMUTL
IF DFN=""
QUIT
+2 SET NX=$ORDER(^DGPM("ATID1",DFN,NX))
IF NX=""
QUIT
SET ADM=+$ORDER(^(NX,0))
SET XX=$GET(^DGPM(ADM,0))
SET DISC=$PIECE(XX,"^",17)
IF DISC'=""
SET DISC=$PIECE($GET(^DGPM(DISC,0)),"^",1)
+3 IF '$DATA(^FHPT(FHDFN,"A",ADM,0))
QUIT
IF $PIECE(X5,"^",1)<$SELECT($DATA(^FHPT(FHDFN,"A",ADM,0))
QUIT
+4 SET W1=$SELECT($PIECE(XX,"^",6):$PIECE(XX,"^",6),1:0)
SET WD=$PIECE($GET(^FH(119.6,+W1,0)),"^",2)
IF 'WD
SET WD=0
+5 QUIT
NS ; Nutrition Status in inverse date order
+1 KILL ^TMP($JOB,"FHNS")
SET FHX1=9999999-(EDT+.3)
SET FHX2=9999999-(SDT+.0001)
SET ZZ=""
+2 FOR XX=FHX1:0
SET XX=$ORDER(^FHPT(FHDFN,"S",XX))
IF XX<1!(XX>FHX2)
QUIT
SET X=$GET(^(XX,0))
DO STOR
+3 IF '$DATA(^TMP($JOB,"FHNS"))
SET XX=FHX1
SET FHX1=$ORDER(^FHPT(FHDFN,"S",FHX1))
IF FHX1=""
QUIT
SET X=$GET(^(FHX1,0))
DO STOR
+4 QUIT
STOR ; Store Nutrition Status by inverse date
+1 IF ZZ'=($PIECE(X,"^",1)\1)
SET ^TMP($JOB,"FHNS",XX,0)=X
+2 SET ZZ=$PIECE(X,"^",1)\1
+3 QUIT
CALC ; Calculate Average
+1 IF $GET(N(0))'=""
SET L=0
DO C1
+2 FOR L=0:0
SET L=$ORDER(N(L))
IF L<1
QUIT
DO C1
+3 QUIT
C1 FOR K=1:1:5
Begin DoDot:1
+1 SET X=$SELECT(ND:$PIECE(N(L),"^",K)/ND,1:"")
+2 SET X=$JUSTIFY(X,0,0)
IF '$DATA(S(L))
SET S(L)=""
+3 SET $PIECE(S(L),"^",K)=$PIECE(S(L),"^",K)+X
+4 SET $PIECE(S(L),"^",6)=$PIECE(S(L),"^",6)+X
+5 SET $PIECE(TOT,"^",K)=$PIECE(TOT,"^",K)+X
+6 SET $PIECE(TOT,"^",6)=$PIECE(TOT,"^",6)+X
+7 QUIT
End DoDot:1
+8 QUIT
P0 ; Print summary
+1 SET DTP=SDT
DO DTP^FH
SET DTE=DTP_" to "
SET DTP=EDT
DO DTP^FH
SET DTE=DTE_DTP
+2 DO NOW^%DTC
SET (NOW,DTP)=%
DO DTP^FH
SET PG=0
SET LN=""
SET $PIECE(LN,"-",100)=""
DO HDR
+3 KILL ^TMP($JOB)
FOR W1=0:0
SET W1=$ORDER(S(W1))
IF W1=""
QUIT
DO P1
+4 SET NAM=""
FOR W1=0:0
SET NAM=$ORDER(^TMP($JOB,NAM))
IF NAM=""
QUIT
SET D1=^(NAM)
DO P2
+5 IF $GET(S(0))'=""
SET D1=$GET(S(0))
WRITE !
Begin DoDot:1
+6 WRITE ?16,"UNKNOWN",?48
+7 FOR K=1:1:5
SET X=$PIECE(D1,"^",K)
WRITE $SELECT(X:$JUSTIFY(X,7),1:$JUSTIFY("",7))
SET X=$SELECT($PIECE(D1,"^",6):X/$PIECE(D1,"^",6)*100,1:"")
WRITE $SELECT(X:$JUSTIFY(X,5,0),1:$JUSTIFY("",5))
+8 SET X=$PIECE(D1,"^",6)
WRITE $SELECT(X:$JUSTIFY(X,7),1:$JUSTIFY("",7))
QUIT
End DoDot:1
+9 WRITE !?16,LN,!?16,"Grand Total",?48
FOR K=1:1:5
SET X=$PIECE(TOT,"^",K)
WRITE $SELECT(X:$JUSTIFY(X,7),1:$JUSTIFY("",7))
SET X=$SELECT($PIECE(TOT,"^",6):X/$PIECE(TOT,"^",6)*100,1:"")
WRITE $SELECT(X:$JUSTIFY(X,5,0),1:$JUSTIFY("",5))
+10 SET X=$PIECE(TOT,"^",6)
WRITE $SELECT(X:$JUSTIFY(X,7),1:$JUSTIFY("",7))
+11 WRITE !
QUIT
P1 IF SRT="W"
SET NAM=$PIECE($GET(^FH(119.6,+W1,0)),"^",1)
+1 IF '$TEST
SET NAM=$PIECE($GET(^VA(200,+W1,0)),"^",1)
+2 IF NAM=""
QUIT
SET ^TMP($JOB,NAM_"~"_W1)=S(W1)
QUIT
P2 IF $Y>(IOSL-8)
DO HDR
WRITE !?16,$PIECE(NAM,"~",1),?48
+1 FOR K=1:1:5
SET X=$PIECE(D1,"^",K)
WRITE $SELECT(X:$JUSTIFY(X,7),1:$JUSTIFY("",7))
SET X=$SELECT($PIECE(D1,"^",6):X/$PIECE(D1,"^",6)*100,1:"")
WRITE $SELECT(X:$JUSTIFY(X,5,0),1:$JUSTIFY("",5))
+2 SET X=$PIECE(D1,"^",6)
WRITE $SELECT(X:$JUSTIFY(X,7),1:$JUSTIFY("",7))
+3 QUIT
HDR IF '($EXTRACT(IOST,1,2)'="C-"&'PG)
WRITE @IOF
SET PG=PG+1
WRITE !?16,DTP,!!?42,"N U T R I T I O N S T A T U S A V E R A G E",?109,"Page ",PG
+1 WRITE !!?(132-$LENGTH(DTE)\2),DTE
+2 WRITE !!?16,$SELECT(SRT="C":"CLINICIAN",1:"WARD"),?54,"I % II % III % IV % UNC % TOTAL",!?16,LN,!
QUIT
