FHASN4 ; HISC/NCA - Nutrition Status Matrix (cont.) ;8/3/94 11:11
;;5.5;DIETETICS;;Jan 28, 2005
Q0 ; Process Screening
K S,^TMP($J),CTN,CTR S CT=0,ANS=""
F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1'>0 D F0
G P0
F0 I WRDS,W1'=WRDS Q
F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN<1 S ADM=$G(^FHPT("AW",W1,FHDFN)) Q:ADM<1 S (NEW,OLD)=0 D Q1
Q
Q1 ; Process screening inpatients for status comparison
S ADTE=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",1) Q:ADTE=""
S DSCH=$P($G(^DGPM(ADM,0)),"^",17) S:DSCH>0 DSCH=$P($G(^DGPM(+DSCH,0)),"^",1)
I FHX1=2 S SDT=ADTE,EDT=DT
S X1=EDT\1,X2=ADTE\1 D ^%DTC Q:'%Y
I FHX1=1 Q:X<NOM I X'>NOM,SDT<(ADTE\1) Q
I FHX1=2 Q:X'=NOM
I DSCH,DSCH>SDT,DSCH<EDT Q
; Tabulate status for new
S X4=EDT+1,X4=X4+.0001,X4=9999999-X4
S X4=$O(^FHPT(FHDFN,"S",X4)) G:'X4 Q2 S X5=^(X4,0)
I $P(X5,"^",1)<$S(SDT:SDT,1:9999999) G Q2:$P(X5,"^",1)<ADTE,CNT
S NEW=$S($P(X5,"^",2)<5:$P(X5,"^",2),1:5)
G Q3
CNT ; Count unchanged status
S (OLD,NEW)=$S($P(X5,"^",2)<5:$P(X5,"^",2),1:5)
G Q5
Q2 ; Unclassified New
S NEW=5
Q3 ; Tabulate status for old
S L1=SDT\1,L1=L1-.0001
S L1=$O(^FHPT(FHDFN,"S","B",L1)) G:L1=""!(L1\1>EDT) Q4
S L1=9999999-L1,X6=$G(^FHPT(FHDFN,"S",L1,0)) G:X6="" Q4
S X1=SDT\1-.0001,X1=X1\1,X2=3 D C^%DTC S THR=X
I $P(X6,"^",1)>$S(THR:THR+.3,1:9999999) G:SDT\1=ADTE\1 Q4 S L1=$O(^FHPT(FHDFN,"S",L1)) G:L1="" Q4 S X6=$G(^(L1,0)) G:$P(X6,"^",1)<ADTE Q4
S OLD=$S($P(X6,"^",2)<5:$P(X6,"^",2),1:5)
G Q5
Q4 ; Unclassified Old
S OLD=5
Q5 ; Set Classification for Old and New
I OLD=NEW S:'$D(CTR(W1)) CTR(W1)="" S $P(CTR(W1),"^",OLD)=$P(CTR(W1),"^",OLD)+1,$P(CTR(W1),"^",6)=$P(CTR(W1),"^",6)+1
S:'$D(S(W1,OLD)) S(W1,OLD)="" S $P(S(W1,OLD),"^",NEW)=$P(S(W1,OLD),"^",NEW)+1
S:'$D(CTN(W1)) CTN(W1)="" S $P(CTN(W1),"^",OLD)=$P(CTN(W1),"^",OLD)+1
I OLD=NEW Q:OLD'=5
S CT=CT+1
S:'$D(^TMP($J,"VEC1",W1,OLD,NEW,CT)) ^TMP($J,"VEC1",W1,OLD,NEW,CT)=""
D PATNAME^FHOMUTL I DFN="" Q
S Y=$P($G(^DPT(DFN,0)),"^",1) S:Y="" Y="Unknown" D PID^FHDPA
S ^TMP($J,"VEC1",W1,OLD,NEW,CT)=$E(Y,1,30)_"^"_BID
S $P(^TMP($J,"VEC1",W1,OLD,NEW,CT),"^",NEW+2)=$P(^TMP($J,"VEC1",W1,OLD,NEW,CT),"^",NEW+2)+1
Q
P0 ; Print Summary
D NOW^%DTC S (NOW,DTP)=% D DTP^FH S HD=DTP S PG=0,LN="",$P(LN,"-",80)=""
I FHX1=1 S DTP=SDT D DTP^FH S DTE=DTP_" to " S DTP=EDT D DTP^FH S DTE=DTE_DTP
I FHX1=2 S DTE="Admission "_NOM_" Days to "_HD
F W1=0:0 S W1=$O(S(W1)) Q:W1="" F ST=0:0 S ST=$O(S(W1,ST)) Q:ST="" D P1
F W1=0:0 S W1=$O(CTN(W1)) Q:W1="" S NAM=$P($G(^FH(119.6,+W1,0)),"^",1) S:NAM'="" ^TMP($J,"CNT",NAM_"~"_W1,0)=$P(CTN(W1),"^",1)_"^"_$P(CTN(W1),"^",2)_"^"_$P(CTN(W1),"^",3)_"^"_$P(CTN(W1),"^",4)_"^"_$P(CTN(W1),"^",5)_"^"_$G(CTR(W1))
S (NAM,STS)="",N=1
F W1=0:0 S NAM=$O(^TMP($J,"VEC2",NAM)) Q:NAM=""!(ANS="^") D HDR^FHASN3:N=1,HD^FHASN3:N'=1 S (TOT,SUM)=0,TOT1="",N=N+1 F ST=0:0 S ST=$O(^TMP($J,"VEC2",NAM,ST)) D:ST<1 LAST Q:ST<1!(ANS="^") S STS=ST,D1=^(STS,0) D P2
K ^TMP($J),CTN,CTR,N,SUM,TOT,TOT1,X
W ! Q
P1 S NAM=$P($G(^FH(119.6,+W1,0)),"^",1)
Q:NAM="" S ^TMP($J,"VEC2",NAM_"~"_W1,ST,0)=$G(S(W1,ST))
F LL=1:1:5 I $D(^TMP($J,"VEC1",W1,ST,LL)) F CT=0:0 S CT=$O(^TMP($J,"VEC1",W1,ST,LL,CT)) Q:CT<1 S ^TMP($J,"VEC2",NAM_"~"_W1,ST,"NS",LL,CT)=$G(^TMP($J,"VEC1",W1,ST,LL,CT))
Q
P2 D:$Y'<(IOSL-3) HD^FHASN3 Q:ANS="^"
W !,$S(STS=1:"I",STS=2:"II",STS=3:"III",STS=4:"IV",1:"UNC")
S TOT=$G(^TMP($J,"CNT",NAM,0)) W ?24,$J($P(TOT,"^",STS),7) S SUM=SUM+$P(TOT,"^",STS)
W ?37 F K=1:1:5 S X=$P(D1,"^",K) W $J(X,7) S $P(TOT1,"^",K)=$P(TOT1,"^",K)+X
S X=$P(TOT,"^",5+STS) W $J(X,7)
F LL=0:0 S LL=$O(^TMP($J,"VEC2",NAM,STS,"NS",LL)) Q:LL<1 F CT=0:0 S CT=$O(^TMP($J,"VEC2",NAM,STS,"NS",LL,CT)) Q:CT<1 S Y=^(CT) W !?1,$P(Y,"^",2),?10,$E($P(Y,"^",1),1,26),?37 D
.F L=1:1:5 S AST=$P(Y,"^",L+2) S:AST AST="*" W $J(AST,7)
.Q
Q
LAST ; Last Total Line
W !,LN,!,"Total",?24,$J(SUM,7),?37 F L=1:1:5 W $J($P(TOT1,"^",L),7)
W $J($S($P(TOT,"^",11)'="":$P(TOT,"^",11),1:""),7)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHASN4 3970 printed Dec 13, 2024@01:47:04 Page 2
FHASN4 ; HISC/NCA - Nutrition Status Matrix (cont.) ;8/3/94 11:11
+1 ;;5.5;DIETETICS;;Jan 28, 2005
Q0 ; Process Screening
+1 KILL S,^TMP($JOB),CTN,CTR
SET CT=0
SET ANS=""
+2 FOR W1=0:0
SET W1=$ORDER(^FH(119.6,W1))
if W1'>0
QUIT
DO F0
+3 GOTO P0
F0 IF WRDS
IF W1'=WRDS
QUIT
+1 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("AW",W1,FHDFN))
if FHDFN<1
QUIT
SET ADM=$GET(^FHPT("AW",W1,FHDFN))
if ADM<1
QUIT
SET (NEW,OLD)=0
DO Q1
+2 QUIT
Q1 ; Process screening inpatients for status comparison
+1 SET ADTE=$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",1)
if ADTE=""
QUIT
+2 SET DSCH=$PIECE($GET(^DGPM(ADM,0)),"^",17)
if DSCH>0
SET DSCH=$PIECE($GET(^DGPM(+DSCH,0)),"^",1)
+3 IF FHX1=2
SET SDT=ADTE
SET EDT=DT
+4 SET X1=EDT\1
SET X2=ADTE\1
DO ^%DTC
if '%Y
QUIT
+5 IF FHX1=1
if X<NOM
QUIT
IF X'>NOM
IF SDT<(ADTE\1)
QUIT
+6 IF FHX1=2
if X'=NOM
QUIT
+7 IF DSCH
IF DSCH>SDT
IF DSCH<EDT
QUIT
+8 ; Tabulate status for new
+9 SET X4=EDT+1
SET X4=X4+.0001
SET X4=9999999-X4
+10 SET X4=$ORDER(^FHPT(FHDFN,"S",X4))
if 'X4
GOTO Q2
SET X5=^(X4,0)
+11 IF $PIECE(X5,"^",1)<$SELECT(SDT:SDT,1:9999999)
if $PIECE(X5,"^",1)<ADTE
GOTO Q2
GOTO CNT
+12 SET NEW=$SELECT($PIECE(X5,"^",2)<5:$PIECE(X5,"^",2),1:5)
+13 GOTO Q3
CNT ; Count unchanged status
+1 SET (OLD,NEW)=$SELECT($PIECE(X5,"^",2)<5:$PIECE(X5,"^",2),1:5)
+2 GOTO Q5
Q2 ; Unclassified New
+1 SET NEW=5
Q3 ; Tabulate status for old
+1 SET L1=SDT\1
SET L1=L1-.0001
+2 SET L1=$ORDER(^FHPT(FHDFN,"S","B",L1))
if L1=""!(L1\1>EDT)
GOTO Q4
+3 SET L1=9999999-L1
SET X6=$GET(^FHPT(FHDFN,"S",L1,0))
if X6=""
GOTO Q4
+4 SET X1=SDT\1-.0001
SET X1=X1\1
SET X2=3
DO C^%DTC
SET THR=X
+5 IF $PIECE(X6,"^",1)>$SELECT(THR:THR+.3,1:9999999)
if SDT\1=ADTE\1
GOTO Q4
SET L1=$ORDER(^FHPT(FHDFN,"S",L1))
if L1=""
GOTO Q4
SET X6=$GET(^(L1,0))
if $PIECE(X6,"^",1)<ADTE
GOTO Q4
+6 SET OLD=$SELECT($PIECE(X6,"^",2)<5:$PIECE(X6,"^",2),1:5)
+7 GOTO Q5
Q4 ; Unclassified Old
+1 SET OLD=5
Q5 ; Set Classification for Old and New
+1 IF OLD=NEW
if '$DATA(CTR(W1))
SET CTR(W1)=""
SET $PIECE(CTR(W1),"^",OLD)=$PIECE(CTR(W1),"^",OLD)+1
SET $PIECE(CTR(W1),"^",6)=$PIECE(CTR(W1),"^",6)+1
+2 if '$DATA(S(W1,OLD))
SET S(W1,OLD)=""
SET $PIECE(S(W1,OLD),"^",NEW)=$PIECE(S(W1,OLD),"^",NEW)+1
+3 if '$DATA(CTN(W1))
SET CTN(W1)=""
SET $PIECE(CTN(W1),"^",OLD)=$PIECE(CTN(W1),"^",OLD)+1
+4 IF OLD=NEW
if OLD'=5
QUIT
+5 SET CT=CT+1
+6 if '$DATA(^TMP($JOB,"VEC1",W1,OLD,NEW,CT))
SET ^TMP($JOB,"VEC1",W1,OLD,NEW,CT)=""
+7 DO PATNAME^FHOMUTL
IF DFN=""
QUIT
+8 SET Y=$PIECE($GET(^DPT(DFN,0)),"^",1)
if Y=""
SET Y="Unknown"
DO PID^FHDPA
+9 SET ^TMP($JOB,"VEC1",W1,OLD,NEW,CT)=$EXTRACT(Y,1,30)_"^"_BID
+10 SET $PIECE(^TMP($JOB,"VEC1",W1,OLD,NEW,CT),"^",NEW+2)=$PIECE(^TMP($JOB,"VEC1",W1,OLD,NEW,CT),"^",NEW+2)+1
+11 QUIT
P0 ; Print Summary
+1 DO NOW^%DTC
SET (NOW,DTP)=%
DO DTP^FH
SET HD=DTP
SET PG=0
SET LN=""
SET $PIECE(LN,"-",80)=""
+2 IF FHX1=1
SET DTP=SDT
DO DTP^FH
SET DTE=DTP_" to "
SET DTP=EDT
DO DTP^FH
SET DTE=DTE_DTP
+3 IF FHX1=2
SET DTE="Admission "_NOM_" Days to "_HD
+4 FOR W1=0:0
SET W1=$ORDER(S(W1))
if W1=""
QUIT
FOR ST=0:0
SET ST=$ORDER(S(W1,ST))
if ST=""
QUIT
DO P1
+5 FOR W1=0:0
SET W1=$ORDER(CTN(W1))
if W1=""
QUIT
SET NAM=$PIECE($GET(^FH(119.6,+W1,0)),"^",1)
if NAM'=""
SET ^TMP($JOB,"CNT",NAM_"~"_W1,0)=$PIECE(CTN(W1),"^",1)_"^"_$PIECE(CTN(W1),"^",2)_"^"_$PIECE(CTN(W1),"^",3)_"^"_$PIECE(CTN(W1),"^",4)_"^"_$PIECE(CTN(W1),"^",5)_"^"_$GET(CTR(W1))
+6 SET (NAM,STS)=""
SET N=1
+7 FOR W1=0:0
SET NAM=$ORDER(^TMP($JOB,"VEC2",NAM))
if NAM=""!(ANS="^")
QUIT
if N=1
DO HDR^FHASN3
if N'=1
DO HD^FHASN3
SET (TOT,SUM)=0
SET TOT1=""
SET N=N+1
FOR ST=0:0
SET ST=$ORDER(^TMP($JOB,"VEC2",NAM,ST))
if ST<1
DO LAST
if ST<1!(ANS="^")
QUIT
SET STS=ST
SET D1=^(STS,0)
DO P2
+8 KILL ^TMP($JOB),CTN,CTR,N,SUM,TOT,TOT1,X
+9 WRITE !
QUIT
P1 SET NAM=$PIECE($GET(^FH(119.6,+W1,0)),"^",1)
+1 if NAM=""
QUIT
SET ^TMP($JOB,"VEC2",NAM_"~"_W1,ST,0)=$GET(S(W1,ST))
+2 FOR LL=1:1:5
IF $DATA(^TMP($JOB,"VEC1",W1,ST,LL))
FOR CT=0:0
SET CT=$ORDER(^TMP($JOB,"VEC1",W1,ST,LL,CT))
if CT<1
QUIT
SET ^TMP($JOB,"VEC2",NAM_"~"_W1,ST,"NS",LL,CT)=$GET(^TMP($JOB,"VEC1",W1,ST,LL,CT))
+3 QUIT
P2 if $Y'<(IOSL-3)
DO HD^FHASN3
if ANS="^"
QUIT
+1 WRITE !,$SELECT(STS=1:"I",STS=2:"II",STS=3:"III",STS=4:"IV",1:"UNC")
+2 SET TOT=$GET(^TMP($JOB,"CNT",NAM,0))
WRITE ?24,$JUSTIFY($PIECE(TOT,"^",STS),7)
SET SUM=SUM+$PIECE(TOT,"^",STS)
+3 WRITE ?37
FOR K=1:1:5
SET X=$PIECE(D1,"^",K)
WRITE $JUSTIFY(X,7)
SET $PIECE(TOT1,"^",K)=$PIECE(TOT1,"^",K)+X
+4 SET X=$PIECE(TOT,"^",5+STS)
WRITE $JUSTIFY(X,7)
+5 FOR LL=0:0
SET LL=$ORDER(^TMP($JOB,"VEC2",NAM,STS,"NS",LL))
if LL<1
QUIT
FOR CT=0:0
SET CT=$ORDER(^TMP($JOB,"VEC2",NAM,STS,"NS",LL,CT))
if CT<1
QUIT
SET Y=^(CT)
WRITE !?1,$PIECE(Y,"^",2),?10,$EXTRACT($PIECE(Y,"^",1),1,26),?37
Begin DoDot:1
+6 FOR L=1:1:5
SET AST=$PIECE(Y,"^",L+2)
if AST
SET AST="*"
WRITE $JUSTIFY(AST,7)
+7 QUIT
End DoDot:1
+8 QUIT
LAST ; Last Total Line
+1 WRITE !,LN,!,"Total",?24,$JUSTIFY(SUM,7),?37
FOR L=1:1:5
WRITE $JUSTIFY($PIECE(TOT1,"^",L),7)
+2 WRITE $JUSTIFY($SELECT($PIECE(TOT,"^",11)'="":$PIECE(TOT,"^",11),1:""),7)
+3 QUIT
