FHASN71 ; HISC/NCA - Print Status Average (cont.) ;9/28/95 10:52
;;5.5;DIETETICS;**30**;Jan 28, 2005;Build 4
;IA # 1071 - DGPMSTAT
;IA # 1096 - PATIENT MOVEMENT file cross reference
;IA # 2056 - Data Base Server API: Data Retriever Utilities
;IA # 2090 - ACCESS TO PATIENT MOVEMENT DATA
Q0 ; Process Screening all patients
K CLIN,DWRD,LIST,LST,NAME,S,WARD,WC,WLCN,WRD,X,X1
S TOT=""
;Build lists of MAS wards, ward names, ward clinicians, clinician names
;DWRD - Array MAS Wards
;FHWN - Array Ward Names
;FHWC - Array Ward Clinicains
;FHWCN - Array Ward Clinican Names
F WRD=0:0 S WRD=$O(^FH(119.6,WRD)) Q:WRD<1 D
. F LST=0:0 S LST=$O(^FH(119.6,WRD,"W",LST)) Q:LST<1 D
. . S X=+$G(^(LST,0))
. . S:'$D(DWRD(X)) DWRD(X)=WRD
. S FHWN(WRD)=$P($G(^FH(119.6,WRD,0)),U)
. F WC=0:0 S WC=$O(^FH(119.6,WRD,2,WC)) Q:WC<1 D
. . S CLIN=+$G(^FH(119.6,WRD,2,WC,0))
. . S LIST(WRD,CLIN)=""
. . I '$D(FHWCN(CLIN)) S FHWCN(CLIN)=$$GET1^DIQ(200,CLIN_",",.01)
. . S LIST(WRD,CLIN)=""
. S (X,X1)=""
. F S X=$O(LIST(WRD,X)) Q:X="" S X1=X1_X_"|"
. I X1'="" S FHWC(WRD)=X1
. K CLIN,LIST,WC,X,X1
;Process all persons in the NUTRITION PERSON file
F FHDFN=0:0 S FHDFN=$O(^FHPT(FHDFN)) Q:FHDFN<1 I $D(^FHPT(FHDFN,0)) K N S ND=0 D TS,CALC
;Build sort array, print summary
D BSA,PS
;Variable clean up and exit
K ^TMP($J)
;D KILL^XUSCLEAN
Q
TS ; Tabulate status
D PATNAME^FHOMUTL I DFN="" Q
S DGT=EDT+1,DGT=DGT+.0000001
S (DGA1,DG1,DGXFR0)=""
D ^DGPMSTAT
Q:DGA1=""!(DG1="")
S ADM=DGA1,XX=$G(^DGPM(ADM,0))
S 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)
S 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=$G(FHWC(+W1)) S:'WD WD=0
I '$D(^FHPT(FHDFN,"S",0)) D UC Q
D NS I '$D(^TMP($J,"FHNS")) D UC 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 inpatient with ADM
I $P(X5,"^",1)<$S($D(^FHPT(FHDFN,"A",ADM,0)):$P(^(0),"^",1),1:9999999) D Q
. D GADM
. I '$D(^FHPT(FHDFN,"A",ADM,0)) D UC Q
. I $P(X5,"^",1)<$S($D(^FHPT(FHDFN,"A",ADM,0)):$P(^(0),"^",1),1:9999999) D UC Q
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=$G(FHWC(+W1))
S:'WD WD=0
I S1,S1<5 D SC Q
UC ; Unclassified
S S1=5
SC ; Set Classification
S X=$S(SRT="W":W1,1:WD)
S:'$D(N(X)) N(X)=""
S $P(N(X),U,S1)=$P(N(X),U,S1)+1
S ND=ND+1
Q
GADM ; Get ADM for patient
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=$G(FHWC(+W1)) 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
I SRT="W" F L=0:0 S L=$O(N(L)) Q:L<1 D C1
I SRT="C" S L="" F S L=$O(N(L)) Q:L="" D C1
Q
C1 ;Calculate Averages continued
F K=1:1:5 D
. S X=$S(ND:$P(N(L),U,K)/ND,1:"")
. S X=$J(X,0,0)
. S:'$D(S(L)) S(L)=""
. S $P(S(L),U,K)=$P(S(L),U,K)+X
. S $P(S(L),U,6)=$P(S(L),U,6)+X
. S $P(TOT,U,K)=$P(TOT,U,K)+X
. S $P(TOT,U,6)=$P(TOT,U,6)+X
Q
BSA ;Build sort array
;SA - Sort Array
;SN - Sort Name
K SA,SN
S W1=""
F S W1=$O(S(W1)) Q:W1="" D
. I W1=0 Q
. I SRT="W" S SN=$G(FHWN(W1))
. I SRT="C" D
. . S X=$P(W1,"|"),SN=$G(FHWCN(X))
. . F X=2:1 S X1=$P($G(W1),"|",X) Q:X1="" S SN=SN_" - "_$G(FHWCN(X1))
. S SN=SN_"~"_W1
. S SA(SN)=""
K SN
Q
PS ; 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
S X="" F S X=$O(SA(X)) Q:X="" D
. S NAME=$P(X,"~")
. S W1=$P(X,"~",2)
. S D1=S(W1)
. D PSD
I $G(S(0))'="" S NAME="UNKNOWN",D1=$G(S(0)) D PSD
S NAME="Grand Total",D1=TOT W !?16,LN D PSD
W !
Q
PSD ;Print summary detail
D:$Y>(IOSL-8) HDR
W !?16,NAME
I NAME[" - " W !
W ?48
S D3=$P(D1,U,6)
F K=1:1:5 D
. S D2=$P(D1,U,K)
. W $S(D2:$J(D2,7),1:$J("",7))
. S D2=$S(D3:D2/D3*100,1:"")
. W $S(D2:$J(D2,5,0),1:$J("",5))
W $S(D3:$J(D3,7),1:$J("",7))
Q
HDR ;Report Page Header
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHASN71 5209 printed Sep 23, 2025@19:23:08 Page 2
FHASN71 ; HISC/NCA - Print Status Average (cont.) ;9/28/95 10:52
+1 ;;5.5;DIETETICS;**30**;Jan 28, 2005;Build 4
+2 ;IA # 1071 - DGPMSTAT
+3 ;IA # 1096 - PATIENT MOVEMENT file cross reference
+4 ;IA # 2056 - Data Base Server API: Data Retriever Utilities
+5 ;IA # 2090 - ACCESS TO PATIENT MOVEMENT DATA
Q0 ; Process Screening all patients
+1 KILL CLIN,DWRD,LIST,LST,NAME,S,WARD,WC,WLCN,WRD,X,X1
+2 SET TOT=""
+3 ;Build lists of MAS wards, ward names, ward clinicians, clinician names
+4 ;DWRD - Array MAS Wards
+5 ;FHWN - Array Ward Names
+6 ;FHWC - Array Ward Clinicains
+7 ;FHWCN - Array Ward Clinican Names
+8 FOR WRD=0:0
SET WRD=$ORDER(^FH(119.6,WRD))
if WRD<1
QUIT
Begin DoDot:1
+9 FOR LST=0:0
SET LST=$ORDER(^FH(119.6,WRD,"W",LST))
if LST<1
QUIT
Begin DoDot:2
+10 SET X=+$GET(^(LST,0))
+11 if '$DATA(DWRD(X))
SET DWRD(X)=WRD
End DoDot:2
+12 SET FHWN(WRD)=$PIECE($GET(^FH(119.6,WRD,0)),U)
+13 FOR WC=0:0
SET WC=$ORDER(^FH(119.6,WRD,2,WC))
if WC<1
QUIT
Begin DoDot:2
+14 SET CLIN=+$GET(^FH(119.6,WRD,2,WC,0))
+15 SET LIST(WRD,CLIN)=""
+16 IF '$DATA(FHWCN(CLIN))
SET FHWCN(CLIN)=$$GET1^DIQ(200,CLIN_",",.01)
+17 SET LIST(WRD,CLIN)=""
End DoDot:2
+18 SET (X,X1)=""
+19 FOR
SET X=$ORDER(LIST(WRD,X))
if X=""
QUIT
SET X1=X1_X_"|"
+20 IF X1'=""
SET FHWC(WRD)=X1
+21 KILL CLIN,LIST,WC,X,X1
End DoDot:1
+22 ;Process all persons in the NUTRITION PERSON file
+23 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT(FHDFN))
if FHDFN<1
QUIT
IF $DATA(^FHPT(FHDFN,0))
KILL N
SET ND=0
DO TS
DO CALC
+24 ;Build sort array, print summary
+25 DO BSA
DO PS
+26 ;Variable clean up and exit
+27 KILL ^TMP($JOB)
+28 ;D KILL^XUSCLEAN
+29 QUIT
TS ; Tabulate status
+1 DO PATNAME^FHOMUTL
IF DFN=""
QUIT
+2 SET DGT=EDT+1
SET DGT=DGT+.0000001
+3 SET (DGA1,DG1,DGXFR0)=""
+4 DO ^DGPMSTAT
+5 if DGA1=""!(DG1="")
QUIT
+6 SET ADM=DGA1
SET XX=$GET(^DGPM(ADM,0))
+7 SET DISC=$PIECE(XX,"^",17)
+8 if DISC'=""
SET DISC=$PIECE($GET(^DGPM(DISC,0)),"^",1)
+9 if '$DATA(^FHPT(FHDFN,"A",ADM,0))
QUIT
+10 SET MW1=$SELECT($PIECE(DG1,"^",1):$PIECE(DG1,"^",1),1:0)
+11 SET W1=$SELECT($DATA(DWRD(+MW1)):$GET(DWRD(+MW1)),1:0)
+12 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
+13 SET WD=$GET(FHWC(+W1))
if 'WD
SET WD=0
+14 IF '$DATA(^FHPT(FHDFN,"S",0))
DO UC
QUIT
+15 DO NS
IF '$DATA(^TMP($JOB,"FHNS"))
DO UC
QUIT
+16 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
+17 QUIT
CHK ; Check if inpatient with ADM
+1 IF $PIECE(X5,"^",1)<$SELECT($DATA(^FHPT(FHDFN,"A",ADM,0)):$PIECE(^(0),"^",1),1:9999999)
Begin DoDot:1
+2 DO GADM
+3 IF '$DATA(^FHPT(FHDFN,"A",ADM,0))
DO UC
QUIT
+4 IF $PIECE(X5,"^",1)<$SELECT($DATA(^FHPT(FHDFN,"A",ADM,0)):$PIECE(^(0),"^",1),1:9999999)
DO UC
QUIT
End DoDot:1
QUIT
+5 IF DISC
IF $PIECE(X5,"^",1)>DISC
DO GADM
if '$DATA(^FHPT(FHDFN,"A",ADM,0))
QUIT
if DISC&($PIECE(X5,"^",1)>DISC)
QUIT
+6 SET S1=$PIECE(X5,"^",2)
SET D1=$PIECE(X5,"^",3)_"|"
+7 SET W1=$SELECT($PIECE(X5,"^",6)'="":$PIECE(X5,"^",6),1:W1)
+8 if 'W1
SET W1=0
+9 SET WD=$GET(FHWC(+W1))
+10 if 'WD
SET WD=0
+11 IF S1
IF S1<5
DO SC
QUIT
UC ; Unclassified
+1 SET S1=5
SC ; Set Classification
+1 SET X=$SELECT(SRT="W":W1,1:WD)
+2 if '$DATA(N(X))
SET N(X)=""
+3 SET $PIECE(N(X),U,S1)=$PIECE(N(X),U,S1)+1
+4 SET ND=ND+1
+5 QUIT
GADM ; Get ADM for patient
+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=$GET(FHWC(+W1))
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 IF SRT="W"
FOR L=0:0
SET L=$ORDER(N(L))
if L<1
QUIT
DO C1
+3 IF SRT="C"
SET L=""
FOR
SET L=$ORDER(N(L))
if L=""
QUIT
DO C1
+4 QUIT
C1 ;Calculate Averages continued
+1 FOR K=1:1:5
Begin DoDot:1
+2 SET X=$SELECT(ND:$PIECE(N(L),U,K)/ND,1:"")
+3 SET X=$JUSTIFY(X,0,0)
+4 if '$DATA(S(L))
SET S(L)=""
+5 SET $PIECE(S(L),U,K)=$PIECE(S(L),U,K)+X
+6 SET $PIECE(S(L),U,6)=$PIECE(S(L),U,6)+X
+7 SET $PIECE(TOT,U,K)=$PIECE(TOT,U,K)+X
+8 SET $PIECE(TOT,U,6)=$PIECE(TOT,U,6)+X
End DoDot:1
+9 QUIT
BSA ;Build sort array
+1 ;SA - Sort Array
+2 ;SN - Sort Name
+3 KILL SA,SN
+4 SET W1=""
+5 FOR
SET W1=$ORDER(S(W1))
if W1=""
QUIT
Begin DoDot:1
+6 IF W1=0
QUIT
+7 IF SRT="W"
SET SN=$GET(FHWN(W1))
+8 IF SRT="C"
Begin DoDot:2
+9 SET X=$PIECE(W1,"|")
SET SN=$GET(FHWCN(X))
+10 FOR X=2:1
SET X1=$PIECE($GET(W1),"|",X)
if X1=""
QUIT
SET SN=SN_" - "_$GET(FHWCN(X1))
End DoDot:2
+11 SET SN=SN_"~"_W1
+12 SET SA(SN)=""
End DoDot:1
+13 KILL SN
+14 QUIT
PS ; 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 SET X=""
FOR
SET X=$ORDER(SA(X))
if X=""
QUIT
Begin DoDot:1
+4 SET NAME=$PIECE(X,"~")
+5 SET W1=$PIECE(X,"~",2)
+6 SET D1=S(W1)
+7 DO PSD
End DoDot:1
+8 IF $GET(S(0))'=""
SET NAME="UNKNOWN"
SET D1=$GET(S(0))
DO PSD
+9 SET NAME="Grand Total"
SET D1=TOT
WRITE !?16,LN
DO PSD
+10 WRITE !
+11 QUIT
PSD ;Print summary detail
+1 if $Y>(IOSL-8)
DO HDR
+2 WRITE !?16,NAME
+3 IF NAME[" - "
WRITE !
+4 WRITE ?48
+5 SET D3=$PIECE(D1,U,6)
+6 FOR K=1:1:5
Begin DoDot:1
+7 SET D2=$PIECE(D1,U,K)
+8 WRITE $SELECT(D2:$JUSTIFY(D2,7),1:$JUSTIFY("",7))
+9 SET D2=$SELECT(D3:D2/D3*100,1:"")
+10 WRITE $SELECT(D2:$JUSTIFY(D2,5,0),1:$JUSTIFY("",5))
End DoDot:1
+11 WRITE $SELECT(D3:$JUSTIFY(D3,7),1:$JUSTIFY("",7))
+12 QUIT
HDR ;Report Page Header
+1 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
+2 WRITE !!?(132-$LENGTH(DTE)\2),DTE
+3 WRITE !!?16,$SELECT(SRT="C":"CLINICIAN",1:"WARD"),?54,"I % II % III % IV % UNC % TOTAL",!?16,LN,!
+4 QUIT
