- 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
