FHMMNREP ;Hines OIFO/RTK,AAC - Multidiv Monitor Report ;10/10/03 11:49
;;5.5;DIETETICS;;Jan 28, 2005
;
COM ;Get Communication Offices
S (ZCO,CO,COXX,CONAME,CONAM,WARD,FHCOMM)="",(ZCOMM,CONUMX,ALLCOMM)=0
;S ZZOUT=$G(^FH(119.73,0)),ZOUT=$P(ZZOUT,"^",4)
S ZZCOUNT=0 F ZZCOUNT=0:0 S ZZCOUNT=$O(^FH(119.73,ZZCOUNT)) Q:ZZCOUNT'>0 S ZOUT=ZZCOUNT
R !!,"Print report for all Communications Offices Y or N: ",ZCO:DTIME W ! S ZCO=$TR(ZCO,"y","Y")
Q:ZCO="^"
I ZCO'="Y" D N2 I (Y=-1)&(CO="") Q
;
DATE ;sets date
S (FHTADM,FHTMON)=0
W ! S %DT="AEPT",%DT("A")="Enter beginning date: " D ^%DT Q:Y<0
S FHSDT=Y,%DT(0)=FHSDT,%DT("A")="Enter ending date: " D ^%DT K %DT(0)
S FHEDT=Y I Y<0 D END Q
D SORTCR S FHSORT=Y I Y="^" D END Q
I FHSORT="C" D FHCL Q:'$D(FHCLIEN) S FHNXIEN=CLNAM
I FHSORT="W" D FHWA Q:'$D(FHWRIEN) S FHNXIEN=WRDNAM
D DEV,END Q
;
FHCL ;
K DIR S DIR(0)="Y",DIR("A")="Select ALL Clinicians",DIR("B")="Y" D ^DIR
I Y=1 S (FHCLIEN,CLNAM)="ALL"
I Y=0 K DIC S DIC="^VA(200,",DIC(0)="AEQM",DIC("A")="Select CLINICIAN: " D ^DIC S FHCLIEN=$P(Y,U,1),CLNAM=$P($G(^VA(200,FHCLIEN,0)),U,1)
I (Y=-1)!($D(DUOUT))!($D(DTOUT)) D END Q
Q
FHWA ;
K DIR S DIR(0)="Y",DIR("A")="Select ALL Wards",DIR("B")="Y" D ^DIR
I Y=1 S (FHWRIEN,WRDNAM)="ALL"
I Y=0 K DIC S DIC="^FH(119.6,",DIC(0)="AEQM" D ^DIC S FHWRIEN=$P(Y,U,1),WRDNAM=$P($G(^FH(119.6,FHWRIEN,0)),U,1)
I (Y=-1)!($D(DUOUT))!($D(DTOUT)) D END Q
Q
EN ;
;^TMP($J,"FHDATA") SUBSCRIPTS (CLINIC OR WARD NAME,DGPM DATE,DGPM ENTRY)
;^TMP($J,"FHDATA") PIECES="PatName^SSN^Monitors?^DischargeDt^DFN^Status"
;
K ^TMP($J,"FHDATA"),FHMON
S I=FHSDT F S I=$O(^DGPM("ATT1",I)) Q:'I!(I>FHEDT) D
.S J=0 F S J=$O(^DGPM("ATT1",I,J)) Q:'J D
..S ZCOMM=ZCOMM+1
..S DFN=$P($G(^DGPM(J,0)),U,3)
..S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" Q
..I '$D(^FHPT(FHDFN,"A",J,"MO","B")) Q
..S II=$P(I,".")
..S FHWARD=$P($G(^DGPM(J,0)),U,6)
..Q:'$D(^FH(119.6,"AW",FHWARD))
..S WRD=$O(^FH(119.6,"AW",FHWARD,""))
..S FHCOMM=$P($G(^FH(119.6,WRD,0)),"^",8),CLN=$P($G(^FH(119.6,WRD,0)),"^",2)
..Q:FHCOMM="" Q:$D(^FH(119.73,FHCOMM,"I"))
..S FHTADM=FHTADM+1
..S ALLCOMM=ALLCOMM+1
..;S CLN=$P($G(^DGPM(J,0)),U,19),WRD=$P($G(^DGPM(J,0)),U,6)
..S INDX=$S(FHSORT="C":CLN,1:WRD) I INDX="" Q
..S INDX=$S(FHSORT="C":$P($G(^VA(200,CLN,0)),U,1),1:$P($G(^FH(119.6,WRD,0)),U,1))
..S $P(^TMP($J,"FHDATA",FHCOMM,INDX,II,J),U,1)=FHCOMM
..S $P(^TMP($J,"FHDATA",FHCOMM,INDX,II,J),U,2)=$E($P($G(^DPT(DFN,0)),U,1),1,23)
..S $P(^TMP($J,"FHDATA",FHCOMM,INDX,II,J),U,5)=DFN
..S $P(^TMP($J,"FHDATA",FHCOMM,INDX,II,J),U,3)=$E($P($G(^DPT(DFN,0)),U,9),6,9)
..I $D(^FHPT(FHDFN,"A",J,"MO","B")) S $P(^TMP($J,"FHDATA",FHCOMM,INDX,II,J),U,7)="Yes",FHTMON=FHTMON+1,MCNT=0 D
...F FHMN=0:0 S FHMN=$O(^FHPT(FHDFN,"A",J,"MO",FHMN)) Q:FHMN'>0 S MCNT=MCNT+1,FHMON(DFN,J,MCNT)=$P($G(^FHPT(FHDFN,"A",J,"MO",FHMN,0)),"^",1)
..S Y=$P($P($G(^FHPT(FHDFN,"A",J,0)),U,14),".",1) I Y X ^DD("DD") S $P(^TMP($J,"FHDATA",FHCOMM,INDX,II,J),U,4)=Y
..I $D(^FHPT(FHDFN,"S",0)) S NS=$O(^FHPT(FHDFN,"S",0)),STAT=$P($G(^FHPT(FHDFN,"S",NS,0)),U,2) S $P(^TMP($J,"FHDATA",FHCOMM,INDX,II,J),U,6)=$P($G(^FH(115.4,STAT,0)),U,1)
..Q
.Q
D ^FHMMNPRT
Q
;
THEND ;Q
;
DEV ;get device and set up queue
W ! K %ZIS,IOP S %ZIS="Q" D ^%ZIS Q:POP
I '$D(IO("Q")) U IO D EN,^%ZISC,END Q
S ZTRTN="EN^FHMMNREP",ZTSAVE("FHSDT")="",ZTSAVE("FHEDT")="",ZTSAVE("ZCOMM")=""
S ZTSAVE("FHNDT")="",ZTSAVE("FHPER")="",ZTSAVE("FHSORT")=""
S ZTSAVE("FHNXIEN")="",ZTSAVE("FHTADM")="",ZTSAVE("FHTMON")=""
S ZTSAVE("ALLCOMM")="",ZTSAVE("ZCO")="",ZTSAVE("COXX")="",ZTSAVE("ZOUT")=""
S ZTSAVE("CONUMX")="",ZTSAVE("CO")="",ZTSAVE("CONAME")=""
S ZTDESC="Dietetics Monitor Report" D ^%ZTLOAD
D ^%ZISC K %ZIS,IOP
D END Q
;
N2 ;Find Communication Office
S DIC=119.73,DIC(0)="AEQ",DIC("A")="Select Communication Offices: "
D ^DIC I Y=-1&(CO="") Q
I Y=-1 Q
S CON=$P(Y,"^",1),CO=CON_"^"_CO,CONAM=$P(Y,"^",2),CONAME=CONAM_"^"_CONAME S CONUMX=$L(CO,"^") G N2
I Y=-1 K DIC Q
Q
;
SORTCR ;
K DIR S DIR(0)="SB^C:CLINICIAN;W:WARD",DIR("A")="Sort by Clinician/Ward"
D ^DIR
Q
END ;kill and quit
K CLN,CLNAM,FHDFN,DFN,I,II,INDX,J,SSN,MCNT
K FHCLIEN,FHEDT,FHMN,FHNDT,FHNXIEN,FHTADM,FHTMON
K FHPER,FHSDT,FHSORT,FHWRIEN,WRD,WRDNAM,X,Y,Z
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHMMNREP 4314 printed Dec 13, 2024@01:47:57 Page 2
FHMMNREP ;Hines OIFO/RTK,AAC - Multidiv Monitor Report ;10/10/03 11:49
+1 ;;5.5;DIETETICS;;Jan 28, 2005
+2 ;
COM ;Get Communication Offices
+1 SET (ZCO,CO,COXX,CONAME,CONAM,WARD,FHCOMM)=""
SET (ZCOMM,CONUMX,ALLCOMM)=0
+2 ;S ZZOUT=$G(^FH(119.73,0)),ZOUT=$P(ZZOUT,"^",4)
+3 SET ZZCOUNT=0
FOR ZZCOUNT=0:0
SET ZZCOUNT=$ORDER(^FH(119.73,ZZCOUNT))
if ZZCOUNT'>0
QUIT
SET ZOUT=ZZCOUNT
+4 READ !!,"Print report for all Communications Offices Y or N: ",ZCO:DTIME
WRITE !
SET ZCO=$TRANSLATE(ZCO,"y","Y")
+5 if ZCO="^"
QUIT
+6 IF ZCO'="Y"
DO N2
IF (Y=-1)&(CO="")
QUIT
+7 ;
DATE ;sets date
+1 SET (FHTADM,FHTMON)=0
+2 WRITE !
SET %DT="AEPT"
SET %DT("A")="Enter beginning date: "
DO ^%DT
if Y<0
QUIT
+3 SET FHSDT=Y
SET %DT(0)=FHSDT
SET %DT("A")="Enter ending date: "
DO ^%DT
KILL %DT(0)
+4 SET FHEDT=Y
IF Y<0
DO END
QUIT
+5 DO SORTCR
SET FHSORT=Y
IF Y="^"
DO END
QUIT
+6 IF FHSORT="C"
DO FHCL
if '$DATA(FHCLIEN)
QUIT
SET FHNXIEN=CLNAM
+7 IF FHSORT="W"
DO FHWA
if '$DATA(FHWRIEN)
QUIT
SET FHNXIEN=WRDNAM
+8 DO DEV
DO END
QUIT
+9 ;
FHCL ;
+1 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Select ALL Clinicians"
SET DIR("B")="Y"
DO ^DIR
+2 IF Y=1
SET (FHCLIEN,CLNAM)="ALL"
+3 IF Y=0
KILL DIC
SET DIC="^VA(200,"
SET DIC(0)="AEQM"
SET DIC("A")="Select CLINICIAN: "
DO ^DIC
SET FHCLIEN=$PIECE(Y,U,1)
SET CLNAM=$PIECE($GET(^VA(200,FHCLIEN,0)),U,1)
+4 IF (Y=-1)!($DATA(DUOUT))!($DATA(DTOUT))
DO END
QUIT
+5 QUIT
FHWA ;
+1 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Select ALL Wards"
SET DIR("B")="Y"
DO ^DIR
+2 IF Y=1
SET (FHWRIEN,WRDNAM)="ALL"
+3 IF Y=0
KILL DIC
SET DIC="^FH(119.6,"
SET DIC(0)="AEQM"
DO ^DIC
SET FHWRIEN=$PIECE(Y,U,1)
SET WRDNAM=$PIECE($GET(^FH(119.6,FHWRIEN,0)),U,1)
+4 IF (Y=-1)!($DATA(DUOUT))!($DATA(DTOUT))
DO END
QUIT
+5 QUIT
EN ;
+1 ;^TMP($J,"FHDATA") SUBSCRIPTS (CLINIC OR WARD NAME,DGPM DATE,DGPM ENTRY)
+2 ;^TMP($J,"FHDATA") PIECES="PatName^SSN^Monitors?^DischargeDt^DFN^Status"
+3 ;
+4 KILL ^TMP($JOB,"FHDATA"),FHMON
+5 SET I=FHSDT
FOR
SET I=$ORDER(^DGPM("ATT1",I))
if 'I!(I>FHEDT)
QUIT
Begin DoDot:1
+6 SET J=0
FOR
SET J=$ORDER(^DGPM("ATT1",I,J))
if 'J
QUIT
Begin DoDot:2
+7 SET ZCOMM=ZCOMM+1
+8 SET DFN=$PIECE($GET(^DGPM(J,0)),U,3)
+9 SET FHZ115="P"_DFN
DO CHECK^FHOMDPA
IF FHDFN=""
QUIT
+10 IF '$DATA(^FHPT(FHDFN,"A",J,"MO","B"))
QUIT
+11 SET II=$PIECE(I,".")
+12 SET FHWARD=$PIECE($GET(^DGPM(J,0)),U,6)
+13 if '$DATA(^FH(119.6,"AW",FHWARD))
QUIT
+14 SET WRD=$ORDER(^FH(119.6,"AW",FHWARD,""))
+15 SET FHCOMM=$PIECE($GET(^FH(119.6,WRD,0)),"^",8)
SET CLN=$PIECE($GET(^FH(119.6,WRD,0)),"^",2)
+16 if FHCOMM=""
QUIT
if $DATA(^FH(119.73,FHCOMM,"I"))
QUIT
+17 SET FHTADM=FHTADM+1
+18 SET ALLCOMM=ALLCOMM+1
+19 ;S CLN=$P($G(^DGPM(J,0)),U,19),WRD=$P($G(^DGPM(J,0)),U,6)
+20 SET INDX=$SELECT(FHSORT="C":CLN,1:WRD)
IF INDX=""
QUIT
+21 SET INDX=$SELECT(FHSORT="C":$PIECE($GET(^VA(200,CLN,0)),U,1),1:$PIECE($GET(^FH(119.6,WRD,0)),U,1))
+22 SET $PIECE(^TMP($JOB,"FHDATA",FHCOMM,INDX,II,J),U,1)=FHCOMM
+23 SET $PIECE(^TMP($JOB,"FHDATA",FHCOMM,INDX,II,J),U,2)=$EXTRACT($PIECE($GET(^DPT(DFN,0)),U,1),1,23)
+24 SET $PIECE(^TMP($JOB,"FHDATA",FHCOMM,INDX,II,J),U,5)=DFN
+25 SET $PIECE(^TMP($JOB,"FHDATA",FHCOMM,INDX,II,J),U,3)=$EXTRACT($PIECE($GET(^DPT(DFN,0)),U,9),6,9)
+26 IF $DATA(^FHPT(FHDFN,"A",J,"MO","B"))
SET $PIECE(^TMP($JOB,"FHDATA",FHCOMM,INDX,II,J),U,7)="Yes"
SET FHTMON=FHTMON+1
SET MCNT=0
Begin DoDot:3
+27 FOR FHMN=0:0
SET FHMN=$ORDER(^FHPT(FHDFN,"A",J,"MO",FHMN))
if FHMN'>0
QUIT
SET MCNT=MCNT+1
SET FHMON(DFN,J,MCNT)=$PIECE($GET(^FHPT(FHDFN,"A",J,"MO",FHMN,0)),"^",1)
End DoDot:3
+28 SET Y=$PIECE($PIECE($GET(^FHPT(FHDFN,"A",J,0)),U,14),".",1)
IF Y
XECUTE ^DD("DD")
SET $PIECE(^TMP($JOB,"FHDATA",FHCOMM,INDX,II,J),U,4)=Y
+29 IF $DATA(^FHPT(FHDFN,"S",0))
SET NS=$ORDER(^FHPT(FHDFN,"S",0))
SET STAT=$PIECE($GET(^FHPT(FHDFN,"S",NS,0)),U,2)
SET $PIECE(^TMP($JOB,"FHDATA",FHCOMM,INDX,II,J),U,6)=$PIECE($GET(^FH(115.4,STAT,0)),U,1)
+30 QUIT
End DoDot:2
+31 QUIT
End DoDot:1
+32 DO ^FHMMNPRT
+33 QUIT
+34 ;
THEND ;Q
+1 ;
DEV ;get device and set up queue
+1 WRITE !
KILL %ZIS,IOP
SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
+2 IF '$DATA(IO("Q"))
USE IO
DO EN
DO ^%ZISC
DO END
QUIT
+3 SET ZTRTN="EN^FHMMNREP"
SET ZTSAVE("FHSDT")=""
SET ZTSAVE("FHEDT")=""
SET ZTSAVE("ZCOMM")=""
+4 SET ZTSAVE("FHNDT")=""
SET ZTSAVE("FHPER")=""
SET ZTSAVE("FHSORT")=""
+5 SET ZTSAVE("FHNXIEN")=""
SET ZTSAVE("FHTADM")=""
SET ZTSAVE("FHTMON")=""
+6 SET ZTSAVE("ALLCOMM")=""
SET ZTSAVE("ZCO")=""
SET ZTSAVE("COXX")=""
SET ZTSAVE("ZOUT")=""
+7 SET ZTSAVE("CONUMX")=""
SET ZTSAVE("CO")=""
SET ZTSAVE("CONAME")=""
+8 SET ZTDESC="Dietetics Monitor Report"
DO ^%ZTLOAD
+9 DO ^%ZISC
KILL %ZIS,IOP
+10 DO END
QUIT
+11 ;
N2 ;Find Communication Office
+1 SET DIC=119.73
SET DIC(0)="AEQ"
SET DIC("A")="Select Communication Offices: "
+2 DO ^DIC
IF Y=-1&(CO="")
QUIT
+3 IF Y=-1
QUIT
+4 SET CON=$PIECE(Y,"^",1)
SET CO=CON_"^"_CO
SET CONAM=$PIECE(Y,"^",2)
SET CONAME=CONAM_"^"_CONAME
SET CONUMX=$LENGTH(CO,"^")
GOTO N2
+5 IF Y=-1
KILL DIC
QUIT
+6 QUIT
+7 ;
SORTCR ;
+1 KILL DIR
SET DIR(0)="SB^C:CLINICIAN;W:WARD"
SET DIR("A")="Sort by Clinician/Ward"
+2 DO ^DIR
+3 QUIT
END ;kill and quit
+1 KILL CLN,CLNAM,FHDFN,DFN,I,II,INDX,J,SSN,MCNT
+2 KILL FHCLIEN,FHEDT,FHMN,FHNDT,FHNXIEN,FHTADM,FHTMON
+3 KILL FHPER,FHSDT,FHSORT,FHWRIEN,WRD,WRDNAM,X,Y,Z
+4 QUIT
