- 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 Mar 13, 2025@20:51:44 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
