FHORX1A.m

FHORX1A ; HISC/REL/NCA/RVD - Diet Activity Report (cont) ;3/17/95  10:06

 ;;5.5;DIETETICS;**1,5,8**;Jan 28, 2005;Build 28

 ;

 ;process inpatient data.

 S PG=0 S FHPIO="** INPATIENT **" D HDR

 S P0="",NN=0 F  S P0=$O(^TMP($J,"I",P0)) Q:P0=""  D LST

 ;

 ;process outpatient data.

 S FHPIO="** OUTPATIENT **" D HDR

 S (FHUSERNM,P0)="",(FHNMSV,NN)=0 F  S P0=$O(^TMP($J,"O",P0)) Q:P0=""  S (FHBRK,FHNON,FHEVE)=0 D LST1

 S:$G(FHP) $P(^FH(119.73,FHP,0),"^",2)=NOW

 I '$G(FHP) F FHII=0:0 S FHII=$O(^FH(119.73,FHII)) Q:FHII'>0  S $P(^FH(119.73,FHII,0),"^",2)=NOW

 Q

 ;

LST K PP S NP=0 F DA=0:0 S DA=$O(^TMP($J,"I",P0,DA)) Q:DA<1  S Z=^(DA) D L1

 D L2 Q

 ;

LST1 K PP S NP=0 F DA=0:0 S DA=$O(^TMP($J,"O",P0,DA)) Q:DA'>0  D T1

 Q

 ;

L1 ; Process event

 S ADM=$P(Z,"^",1),TYP=$P(Z,"^",2),ACT=$P(Z,"^",3),FHORD=$P(Z,"^",4),TXT=$P(Z,"^",5),CLK=$P(Z,"^",6)

 I 'FHORD S NN=NN+1,FHORD=NN

 I "DIT"[TYP D

 .I TYP="D",FHORD=1 S NP=1

 .I $D(PP(TYP,ADM_"~"_FHORD)),ACT="C" K PP(TYP,ADM_"~"_FHORD) Q

 .K PP(TYP) S PP(TYP,ADM_"~"_FHORD)=ACT_"^"_TXT_"^"_CLK Q

 I "OPSF"[TYP D

 .I $D(PP(TYP,ADM_"~"_FHORD)),ACT="C" K PP(TYP,ADM_"~"_FHORD) Q

 .S PP(TYP,ADM_"~"_FHORD)=ACT_"^"_TXT_"^"_CLK Q

 I "LM"[TYP S PP(TYP,ADM_"~"_FHORD)=ACT_"^"_TXT_"^"_CLK

 Q

 ;

L2 S W1=$P(P0,"~",2),R1=$P(P0,"~",4),FHDFN=$P(P0,"~",5)

 D PATNAME^FHOMUTL Q:'$G(DFN)

 S Y0=$G(^DPT(DFN,0))

 S N1=$P(Y0,"^",1)

 ;D PID^FHDPA

 S TC=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",5),SF=$P($G(^(0)),"^",7),SO=$D(^FHPT("ASP",FHDFN,ADM))

 D:$Y>(IOSL-6) HDR W !!,$E(W1_" "_R1,1,20),?22,N1,?50,BID,?63,$S(SF:"SF",1:""),?66,$S(SO:"SO",1:""),?73,TC

 D ALG^FHCLN W !,"Allergies: ",$S(ALG="":"None on file",1:ALG),!

 D ^FHORX1C D:NP NEWP Q

 ;

T1 ; Process outpatient event

 S FHTDAT=$G(^TMP($J,"O",P0,DA)),DFN=$P(P0,"~",4)

 S FHACTI=$P(FHTDAT,"^",1)

 S DTP=$P(FHTDAT,"^",2)

 S BID=$P(FHTDAT,"^",3)

 S FHDESC=$P(FHTDAT,"^",4)

 S FHTC=$P(FHTDAT,"^",5)

 ;I FHBRK=1,(FHDESC["Recurring Meal cancelled"),(FHDESC["Break") Q

 ;I FHNON=1,(FHDESC["Recurring Meal cancelled"),(FHDESC["Noon") Q

 ;I FHEVE=1,(FHDESC["Recurring Meal cancelled"),(FHDESC["Eve") Q

 ;I (FHDESC["Recurring Meal cancelled"),(FHDESC["Break") S FHBRK=1

 ;I (FHDESC["Recurring Meal cancelled"),(FHDESC["Noon") S FHNON=1

 ;I (FHDESC["Recurring Meal cancelled"),(FHDESC["Eve") S FHEVE=1

 S FHDES1=$P(FHDESC,",",1)

 S FHDIET=$P(FHDES1,":",2),FHDIET=$E(FHDIET,2,$L(FHDIET))

 I FHDIET'="",$D(^FH(111,"B",FHDIET)) S FHDIDA=$O(^FH(111,"B",FHDIET,0))

 I $G(FHDIDA),$D(^FH(111,FHDIDA,0)) S FHDIET=$P(^FH(111,FHDIDA,0),U,7)

 S:FHDIET="" FHDIET="NO ORDER"

 S Y=FHDIET

 S W1=$P(P0,"~",2),R1=$P(P0,"~",4),(N1,FHDPTN)=$P(P0,"~",5)

 ;T2

 I $D(^FH(119.8,DA,0)) S FHUSER=$P(^(0),U,9) S:$G(FHUSER) FHUSERN=$P(^VA(200,FHUSER,0),U,1)

 ;S EVT=FHDESC_" by "_FHUSERN

 I FHDESC["Standing" S FHSO1=$P(FHDESC,":",1),FHDESC="Outpatient SO"_$E(FHDESC,$L(FHSO1)+1,$L(FHDESC))

 I FHDESC["Supplemental" S FHSF1=$P(FHDESC,":",1),FHDESC="Outpatient SF"_$E(FHDESC,$L(FHSF1)+1,$L(FHDESC))

 S EVT=FHDESC

 I $Y>(IOSL-6) D HDR

 I (FHNMSV=0)!(FHNMSV'=P0) W !!,$E(W1,1,20),?22,FHDPTN,?50,BID,?73,FHTC D ALG^FHCLN W !,"Allergies: ",$S(ALG="":"None on file",1:ALG),!

 S FHNMSV=P0

 D LNE

 Q

 ;

HDR ;W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 W !?20,"D I E T   A C T I V I T Y   R E P O R T",?72,"Page ",PG

 W @IOF S PG=PG+1 W !?20,"D I E T   A C T I V I T Y   R E P O R T",?72,"Page ",PG

 W !!?(80-$L(H1)\2),H1

 W !,?30,FHPIO

 W !!,"Location",?22,"Patient",?50,"ID#",?62,"Sup/Std  Service"

 Q

 ;

NEWP K ALG I $G(DFN) D ALG^FHCLN I ALG'="" S EVT="Allergies: "_ALG,TYP="A" D LNE^FHORX1C

 Q:'$D(^FHPT(FHDFN,"P"))

 S X1="Pref:" F K=0:0 S K=$O(^FHPT(FHDFN,"P",K)) Q:K<1  S X=^(K,0) D N1

 W:$L(X1)>6 !?12,X1 Q

 ;

N1 S Y=$G(^FH(115.2,+X,0)) Q:$P(Y,"^",2)'="D"

 S Y=" "_$P(Y,"^",1)_" ("_$P(X,"^",2)_")"_$S($P(X,"^",4)="Y":" (D)",1:"") I $L(X1)+$L(Y)>48 W !?12,X1 S X1="Pref:"

 S X1=X1_Y Q

 ;

LNE ; Break line if longer than 58 chars

 I $Y>(IOSL-6) D HDR^FHORX1A W !

 I $L(EVT)<59 G EX

 F KK=59:-1:4 Q:$E(EVT,KK)?1P

 I KK=4 S KK=45 W !?5,$E(EVT,1,58)

 E  W !?5,$E(EVT,1,KK-1)

 S EVT="    "_$E(EVT,KK+1,999) G LNE

EX W !?5,EVT Q

FHORX1A   ; HISC/REL/NCA/RVD - Diet Activity Report (cont) ;3/17/95  10:06

 +1       ;;5.5;DIETETICS;**1,5,8**;Jan 28, 2005;Build 28

 +2       ;

 +3       ;process inpatient data.

 +4        SET PG=0

           SET FHPIO="** INPATIENT **"

           DO HDR

 +5        SET P0=""

           SET NN=0

           FOR 

               SET P0=$ORDER(^TMP($JOB,"I",P0))

               IF P0=""

                   QUIT 

               DO LST

 +6       ;

 +7       ;process outpatient data.

 +8        SET FHPIO="** OUTPATIENT **"

           DO HDR

 +9        SET (FHUSERNM,P0)=""

           SET (FHNMSV,NN)=0

           FOR 

               SET P0=$ORDER(^TMP($JOB,"O",P0))

               IF P0=""

                   QUIT 

               SET (FHBRK,FHNON,FHEVE)=0

               DO LST1

 +10       IF $GET(FHP)

               SET $PIECE(^FH(119.73,FHP,0),"^",2)=NOW

 +11       IF '$GET(FHP)

               FOR FHII=0:0

                   SET FHII=$ORDER(^FH(119.73,FHII))

                   IF FHII'>0

                       QUIT 

                   SET $PIECE(^FH(119.73,FHII,0),"^",2)=NOW

 +12       QUIT 

 +13      ;

LST        KILL PP

           SET NP=0

           FOR DA=0:0

               SET DA=$ORDER(^TMP($JOB,"I",P0,DA))

               IF DA<1

                   QUIT 

               SET Z=^(DA)

               DO L1

 +1        DO L2

           QUIT 

 +2       ;

LST1       KILL PP

           SET NP=0

           FOR DA=0:0

               SET DA=$ORDER(^TMP($JOB,"O",P0,DA))

               IF DA'>0

                   QUIT 

               DO T1

 +1        QUIT 

 +2       ;

L1        ; Process event

 +1        SET ADM=$PIECE(Z,"^",1)

           SET TYP=$PIECE(Z,"^",2)

           SET ACT=$PIECE(Z,"^",3)

           SET FHORD=$PIECE(Z,"^",4)

           SET TXT=$PIECE(Z,"^",5)

           SET CLK=$PIECE(Z,"^",6)

 +2        IF 'FHORD

               SET NN=NN+1

               SET FHORD=NN

 +3        IF "DIT"[TYP

               Begin DoDot:1

 +4                IF TYP="D"

                       IF FHORD=1

                           SET NP=1

 +5                IF $DATA(PP(TYP,ADM_"~"_FHORD))

                       IF ACT="C"

                           KILL PP(TYP,ADM_"~"_FHORD)

                           QUIT 

 +6                KILL PP(TYP)

                   SET PP(TYP,ADM_"~"_FHORD)=ACT_"^"_TXT_"^"_CLK

                   QUIT 

               End DoDot:1

 +7        IF "OPSF"[TYP

               Begin DoDot:1

 +8                IF $DATA(PP(TYP,ADM_"~"_FHORD))

                       IF ACT="C"

                           KILL PP(TYP,ADM_"~"_FHORD)

                           QUIT 

 +9                SET PP(TYP,ADM_"~"_FHORD)=ACT_"^"_TXT_"^"_CLK

                   QUIT 

               End DoDot:1

 +10       IF "LM"[TYP

               SET PP(TYP,ADM_"~"_FHORD)=ACT_"^"_TXT_"^"_CLK

 +11       QUIT 

 +12      ;

L2         SET W1=$PIECE(P0,"~",2)

           SET R1=$PIECE(P0,"~",4)

           SET FHDFN=$PIECE(P0,"~",5)

 +1        DO PATNAME^FHOMUTL

           IF '$GET(DFN)

               QUIT 

 +2        SET Y0=$GET(^DPT(DFN,0))

 +3        SET N1=$PIECE(Y0,"^",1)

 +4       ;D PID^FHDPA

 +5        SET TC=$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",5)

           SET SF=$PIECE($GET(^(0)),"^",7)

           SET SO=$DATA(^FHPT("ASP",FHDFN,ADM))

 +6        IF $Y>(IOSL-6)

               DO HDR

           WRITE !!,$EXTRACT(W1_" "_R1,1,20),?22,N1,?50,BID,?63,$SELECT(SF:"SF",1:""),?66,$SELECT(SO:"SO",1:""),?73,TC

 +7        DO ALG^FHCLN

           WRITE !,"Allergies: ",$SELECT(ALG="":"None on file",1:ALG),!

 +8        DO ^FHORX1C

           IF NP

               DO NEWP

           QUIT 

 +9       ;

T1        ; Process outpatient event

 +1        SET FHTDAT=$GET(^TMP($JOB,"O",P0,DA))

           SET DFN=$PIECE(P0,"~",4)

 +2        SET FHACTI=$PIECE(FHTDAT,"^",1)

 +3        SET DTP=$PIECE(FHTDAT,"^",2)

 +4        SET BID=$PIECE(FHTDAT,"^",3)

 +5        SET FHDESC=$PIECE(FHTDAT,"^",4)

 +6        SET FHTC=$PIECE(FHTDAT,"^",5)

 +7       ;I FHBRK=1,(FHDESC["Recurring Meal cancelled"),(FHDESC["Break") Q

 +8       ;I FHNON=1,(FHDESC["Recurring Meal cancelled"),(FHDESC["Noon") Q

 +9       ;I FHEVE=1,(FHDESC["Recurring Meal cancelled"),(FHDESC["Eve") Q

 +10      ;I (FHDESC["Recurring Meal cancelled"),(FHDESC["Break") S FHBRK=1

 +11      ;I (FHDESC["Recurring Meal cancelled"),(FHDESC["Noon") S FHNON=1

 +12      ;I (FHDESC["Recurring Meal cancelled"),(FHDESC["Eve") S FHEVE=1

 +13       SET FHDES1=$PIECE(FHDESC,",",1)

 +14       SET FHDIET=$PIECE(FHDES1,":",2)

           SET FHDIET=$EXTRACT(FHDIET,2,$LENGTH(FHDIET))

 +15       IF FHDIET'=""

               IF $DATA(^FH(111,"B",FHDIET))

                   SET FHDIDA=$ORDER(^FH(111,"B",FHDIET,0))

 +16       IF $GET(FHDIDA)

               IF $DATA(^FH(111,FHDIDA,0))

                   SET FHDIET=$PIECE(^FH(111,FHDIDA,0),U,7)

 +17       IF FHDIET=""

               SET FHDIET="NO ORDER"

 +18       SET Y=FHDIET

 +19       SET W1=$PIECE(P0,"~",2)

           SET R1=$PIECE(P0,"~",4)

           SET (N1,FHDPTN)=$PIECE(P0,"~",5)

 +20      ;T2

 +21       IF $DATA(^FH(119.8,DA,0))

               SET FHUSER=$PIECE(^(0),U,9)

               IF $GET(FHUSER)

                   SET FHUSERN=$PIECE(^VA(200,FHUSER,0),U,1)

 +22      ;S EVT=FHDESC_" by "_FHUSERN

 +23       IF FHDESC["Standing"

               SET FHSO1=$PIECE(FHDESC,":",1)

               SET FHDESC="Outpatient SO"_$EXTRACT(FHDESC,$LENGTH(FHSO1)+1,$LENGTH(FHDESC))

 +24       IF FHDESC["Supplemental"

               SET FHSF1=$PIECE(FHDESC,":",1)

               SET FHDESC="Outpatient SF"_$EXTRACT(FHDESC,$LENGTH(FHSF1)+1,$LENGTH(FHDESC))

 +25       SET EVT=FHDESC

 +26       IF $Y>(IOSL-6)

               DO HDR

 +27       IF (FHNMSV=0)!(FHNMSV'=P0)

               WRITE !!,$EXTRACT(W1,1,20),?22,FHDPTN,?50,BID,?73,FHTC

               DO ALG^FHCLN

               WRITE !,"Allergies: ",$SELECT(ALG="":"None on file",1:ALG),!

 +28       SET FHNMSV=P0

 +29       DO LNE

 +30       QUIT 

 +31      ;

HDR       ;W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 W !?20,"D I E T   A C T I V I T Y   R E P O R T",?72,"Page ",PG

 +1        WRITE @IOF

           SET PG=PG+1

           WRITE !?20,"D I E T   A C T I V I T Y   R E P O R T",?72,"Page ",PG

 +2        WRITE !!?(80-$LENGTH(H1)\2),H1

 +3        WRITE !,?30,FHPIO

 +4        WRITE !!,"Location",?22,"Patient",?50,"ID#",?62,"Sup/Std  Service"

 +5        QUIT 

 +6       ;

NEWP       KILL ALG

           IF $GET(DFN)

               DO ALG^FHCLN

               IF ALG'=""

                   SET EVT="Allergies: "_ALG

                   SET TYP="A"

                   DO LNE^FHORX1C

 +1        IF '$DATA(^FHPT(FHDFN,"P"))

               QUIT 

 +2        SET X1="Pref:"

           FOR K=0:0

               SET K=$ORDER(^FHPT(FHDFN,"P",K))

               IF K<1

                   QUIT 

               SET X=^(K,0)

               DO N1

 +3        IF $LENGTH(X1)>6

               WRITE !?12,X1

           QUIT 

 +4       ;

N1         SET Y=$GET(^FH(115.2,+X,0))

           IF $PIECE(Y,"^",2)'="D"

               QUIT 

 +1        SET Y=" "_$PIECE(Y,"^",1)_" ("_$PIECE(X,"^",2)_")"_$SELECT($PIECE(X,"^",4)="Y":" (D)",1:"")

           IF $LENGTH(X1)+$LENGTH(Y)>48

               WRITE !?12,X1

               SET X1="Pref:"

 +2        SET X1=X1_Y

           QUIT 

 +3       ;

LNE       ; Break line if longer than 58 chars

 +1        IF $Y>(IOSL-6)

               DO HDR^FHORX1A

               WRITE !

 +2        IF $LENGTH(EVT)<59

               GOTO EX

 +3        FOR KK=59:-1:4

               IF $EXTRACT(EVT,KK)?1P

                   QUIT 

 +4        IF KK=4

               SET KK=45

               WRITE !?5,$EXTRACT(EVT,1,58)

 +5       IF '$TEST

               WRITE !?5,$EXTRACT(EVT,1,KK-1)

 +6        SET EVT="    "_$EXTRACT(EVT,KK+1,999)

           GOTO LNE

EX         WRITE !?5,EVT

           QUIT