FHMMBRPT ;Hines OIFO/JT,RTK,AAC - Multidiv Monitor Brief ;10/10/03 11:49
;;5.5;DIETETICS;;Jan 28, 2005
;
COM ;get Communication Offices
S (ZCO,CO,CONAME,CONAM,WARD,FHCOMM,ZZOUT,ZOUT,CONUMX)="",(COXX,ALLMON,ALLADM,ALLFHPER)=0
;S ZZOUT=$G(^FH(119.73,0)),CONUMX=$P(ZZOUT,"^",4),ZOUT=CONUMX
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 Communication Offices Y or N: ",ZCO:DTIME W ! S ZCO=$TR(ZCO,"y","Y")
I ZCO'="Y" D N2 I (Y=-1)&(CO="") Q
;
DATE ;sets date
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 PG=0,EX=""
I Y<0 D END Q
S FHEDT=Y
D DEV Q
;D END
;
EN ;get admission/monitor information
I ZCO'="Y" S CONUMX=CONUMX-1 G:CONUMX=0 THEND S COXX=$P(CO,"^",CONUMX),NAME=$P(CONAME,"^",CONUMX)
I ZCO="Y" S COXX=COXX+1 G:COXX>ZOUT THEND S NAME=$G(^FH(119.73,COXX,0)),NAME=$P(NAME,"^")
I $D(^FH(119.73,COXX,"I"))!'$D(^FH(119.73,COXX,0)) G EN
;
D NOW^%DTC S Y=X D DD^%DT S FHNDT=Y D PG
S ADMTOT=0,MONTOT=0
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!(EX=U) S REC=$G(^DGPM(J,0)) S WARD=$P(REC,"^",6) Q:WARD="" D COFF Q:FHCOMM="" Q:$D(^FH(119.73,FHCOMM,"I")) Q:FHCOMM'=COXX D
..S DFN=$P(^DGPM(J,0),U,3) I $Y>(IOSL-4) D PG I EX=U Q
..S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" Q
..S Y=$P(I,".") X ^DD("DD") W !,Y,?13,$E($P($G(^DPT(DFN,0)),U,1),1,23)
..W ?39,$E($P($G(^DPT(DFN,0)),U,9),6,9) S ADMTOT=ADMTOT+1
..I $D(^FHPT(FHDFN,"A",J,"MO","B")) W ?48,"Yes" S MONTOT=MONTOT+1
..S Y=$P($P($G(^FHPT(FHDFN,"A",J,0)),U,14),".",1) I Y X ^DD("DD") W ?56,Y
..Q
.Q
I EX=U D THEND Q
W !!,"TOTAL ADMISSIONS: ",?22,ADMTOT S ALLADM=ALLADM+ADMTOT I $Y>(IOSL-4) D PG I EX=U Q
W !,"TOTAL WITH MONITORS:",?22,MONTOT S ALLMON=ALLMON+MONTOT I $Y>(IOSL-4) D PG I EX=U Q
W !,"Percentage of Admissions with Monitors: "
I ADMTOT=0!(MONTOT=0) W "0.0%" D EN Q
S FHPER=(MONTOT/ADMTOT)*100
I $L($P(FHPER,".",2))>2 S FHPER=$P(FHPER,".",1)_"."_$E($P(FHPER,".",2),1,2)
W FHPER,"%" I $Y>(IOSL-4) D PG I EX=U Q
G EN
I IOST?1"C".E W ! K DIR S DIR(0)="E" D ^DIR
Q
;
COFF ;get Communications Offices
Q:'$D(^FH(119.6,"AW",WARD))
S FHWARD=$O(^FH(119.6,"AW",WARD,""))
S FHCOMM=$P($G(^FH(119.6,FHWARD,0)),"^",8)
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^FHMMBRPT",ZTSAVE("FHSDT")="",ZTSAVE("FHEDT")=""
S ZTSAVE=("FHNDT")="",ZTSAVE=("FHPER")="",ZTSAVE("ZCO")=""
S ZTSAVE("CO")="",ZTSAVE("ALLMON")="",ZTSAVE("PG")="",ZTSAVE("EX")=""
S ZTSAVE("ZOUT")="",ZTSAVE("ALLADM")="",ZTSAVE("ALLFHPER")=""
S ZTSAVE("COXX")="",ZTSAVE("CONUMX")="",ZTSAVE("FHCOMM")=""
S ZTSAVE("CONAME")=""
S ZTDESC="Dietetics Monitor Report" D ^%ZTLOAD
D ^%ZISC K %ZIS,IOP
;D END Q
;
END ;kill and quit
K I,J,DFN,FHDFN,SSN,ADMTOT,MONTOT,FHPER,FHSDT,FHEDT,FHNDT,X,Y,PG
Q
;
THEND ;
I IOST?1"C".E W ! K DIR S DIR(0)="E" D ^DIR
S NAME="ALL COMMUNICATION OFFICES " D HDR
W !!,"ALL TOTAL ADMISSIONS: ",?22,ALLADM
W !,"TOTAL WITH MONITORS:",?22,ALLMON
W !,"Percentage of Admissions with Monitors: "
I ALLADM=0!(ALLMON=0) W "0.0%" D END Q
S ALLFHPER=(ALLMON/ALLADM)*100
I $L($P(ALLFHPER,".",2))>2 S ALLFHPER=$P(ALLFHPER,".",1)_"."_$E($P(ALLFHPER,".",2),1,2)
W ALLFHPER,"%" I $Y>(IOSL-4) D PG I EX=U Q
G END Q
;
N2 ;find Communications 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
;
PG ;
I IOST?1"C".E W ! K DIR S DIR(0)="E" D ^DIR I 'Y S EX=U Q
D HDR Q
HDR ;Header
W:$Y @IOF W !,NAME,?30,"MONITOR BRIEF REPORT" W !,FHNDT,?60,"Page: " S PG=PG+1 W PG,!!
W "Admission",?13,"Patient",?39,"SSN",?45,"Monitor?",?56,"Discharge"
W ! F Z=1:1:79 W "="
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHMMBRPT 4028 printed Oct 16, 2024@17:48:45 Page 2
FHMMBRPT ;Hines OIFO/JT,RTK,AAC - Multidiv Monitor Brief ;10/10/03 11:49
+1 ;;5.5;DIETETICS;;Jan 28, 2005
+2 ;
COM ;get Communication Offices
+1 SET (ZCO,CO,CONAME,CONAM,WARD,FHCOMM,ZZOUT,ZOUT,CONUMX)=""
SET (COXX,ALLMON,ALLADM,ALLFHPER)=0
+2 ;S ZZOUT=$G(^FH(119.73,0)),CONUMX=$P(ZZOUT,"^",4),ZOUT=CONUMX
+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 Communication Offices Y or N: ",ZCO:DTIME
WRITE !
SET ZCO=$TRANSLATE(ZCO,"y","Y")
+5 IF ZCO'="Y"
DO N2
IF (Y=-1)&(CO="")
QUIT
+6 ;
DATE ;sets date
+1 WRITE !
SET %DT="AEPT"
SET %DT("A")="Enter beginning date: "
DO ^%DT
if Y<0
QUIT
+2 SET FHSDT=Y
SET %DT(0)=FHSDT
SET %DT("A")="Enter ending date: "
DO ^%DT
KILL %DT(0)
+3 SET PG=0
SET EX=""
+4 IF Y<0
DO END
QUIT
+5 SET FHEDT=Y
+6 DO DEV
QUIT
+7 ;D END
+8 ;
EN ;get admission/monitor information
+1 IF ZCO'="Y"
SET CONUMX=CONUMX-1
if CONUMX=0
GOTO THEND
SET COXX=$PIECE(CO,"^",CONUMX)
SET NAME=$PIECE(CONAME,"^",CONUMX)
+2 IF ZCO="Y"
SET COXX=COXX+1
if COXX>ZOUT
GOTO THEND
SET NAME=$GET(^FH(119.73,COXX,0))
SET NAME=$PIECE(NAME,"^")
+3 IF $DATA(^FH(119.73,COXX,"I"))!'$DATA(^FH(119.73,COXX,0))
GOTO EN
+4 ;
+5 DO NOW^%DTC
SET Y=X
DO DD^%DT
SET FHNDT=Y
DO PG
+6 SET ADMTOT=0
SET MONTOT=0
+7 SET I=FHSDT
FOR
SET I=$ORDER(^DGPM("ATT1",I))
if 'I!(I>FHEDT)
QUIT
Begin DoDot:1
+8 SET J=0
FOR
SET J=$ORDER(^DGPM("ATT1",I,J))
if 'J!(EX=U)
QUIT
SET REC=$GET(^DGPM(J,0))
SET WARD=$PIECE(REC,"^",6)
if WARD=""
QUIT
DO COFF
if FHCOMM=""
QUIT
if $DATA(^FH(119.73,FHCOMM,"I"))
QUIT
if FHCOMM'=COXX
QUIT
Begin DoDot:2
+9 SET DFN=$PIECE(^DGPM(J,0),U,3)
IF $Y>(IOSL-4)
DO PG
IF EX=U
QUIT
+10 SET FHZ115="P"_DFN
DO CHECK^FHOMDPA
IF FHDFN=""
QUIT
+11 SET Y=$PIECE(I,".")
XECUTE ^DD("DD")
WRITE !,Y,?13,$EXTRACT($PIECE($GET(^DPT(DFN,0)),U,1),1,23)
+12 WRITE ?39,$EXTRACT($PIECE($GET(^DPT(DFN,0)),U,9),6,9)
SET ADMTOT=ADMTOT+1
+13 IF $DATA(^FHPT(FHDFN,"A",J,"MO","B"))
WRITE ?48,"Yes"
SET MONTOT=MONTOT+1
+14 SET Y=$PIECE($PIECE($GET(^FHPT(FHDFN,"A",J,0)),U,14),".",1)
IF Y
XECUTE ^DD("DD")
WRITE ?56,Y
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 IF EX=U
DO THEND
QUIT
+18 WRITE !!,"TOTAL ADMISSIONS: ",?22,ADMTOT
SET ALLADM=ALLADM+ADMTOT
IF $Y>(IOSL-4)
DO PG
IF EX=U
QUIT
+19 WRITE !,"TOTAL WITH MONITORS:",?22,MONTOT
SET ALLMON=ALLMON+MONTOT
IF $Y>(IOSL-4)
DO PG
IF EX=U
QUIT
+20 WRITE !,"Percentage of Admissions with Monitors: "
+21 IF ADMTOT=0!(MONTOT=0)
WRITE "0.0%"
DO EN
QUIT
+22 SET FHPER=(MONTOT/ADMTOT)*100
+23 IF $LENGTH($PIECE(FHPER,".",2))>2
SET FHPER=$PIECE(FHPER,".",1)_"."_$EXTRACT($PIECE(FHPER,".",2),1,2)
+24 WRITE FHPER,"%"
IF $Y>(IOSL-4)
DO PG
IF EX=U
QUIT
+25 GOTO EN
+26 IF IOST?1"C".E
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
+27 QUIT
+28 ;
COFF ;get Communications Offices
+1 if '$DATA(^FH(119.6,"AW",WARD))
QUIT
+2 SET FHWARD=$ORDER(^FH(119.6,"AW",WARD,""))
+3 SET FHCOMM=$PIECE($GET(^FH(119.6,FHWARD,0)),"^",8)
+4 QUIT
+5 ;
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^FHMMBRPT"
SET ZTSAVE("FHSDT")=""
SET ZTSAVE("FHEDT")=""
+4 SET ZTSAVE=("FHNDT")=""
SET ZTSAVE=("FHPER")=""
SET ZTSAVE("ZCO")=""
+5 SET ZTSAVE("CO")=""
SET ZTSAVE("ALLMON")=""
SET ZTSAVE("PG")=""
SET ZTSAVE("EX")=""
+6 SET ZTSAVE("ZOUT")=""
SET ZTSAVE("ALLADM")=""
SET ZTSAVE("ALLFHPER")=""
+7 SET ZTSAVE("COXX")=""
SET ZTSAVE("CONUMX")=""
SET ZTSAVE("FHCOMM")=""
+8 SET ZTSAVE("CONAME")=""
+9 SET ZTDESC="Dietetics Monitor Report"
DO ^%ZTLOAD
+10 DO ^%ZISC
KILL %ZIS,IOP
+11 ;D END Q
+12 ;
END ;kill and quit
+1 KILL I,J,DFN,FHDFN,SSN,ADMTOT,MONTOT,FHPER,FHSDT,FHEDT,FHNDT,X,Y,PG
+2 QUIT
+3 ;
THEND ;
+1 IF IOST?1"C".E
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
+2 SET NAME="ALL COMMUNICATION OFFICES "
DO HDR
+3 WRITE !!,"ALL TOTAL ADMISSIONS: ",?22,ALLADM
+4 WRITE !,"TOTAL WITH MONITORS:",?22,ALLMON
+5 WRITE !,"Percentage of Admissions with Monitors: "
+6 IF ALLADM=0!(ALLMON=0)
WRITE "0.0%"
DO END
QUIT
+7 SET ALLFHPER=(ALLMON/ALLADM)*100
+8 IF $LENGTH($PIECE(ALLFHPER,".",2))>2
SET ALLFHPER=$PIECE(ALLFHPER,".",1)_"."_$EXTRACT($PIECE(ALLFHPER,".",2),1,2)
+9 WRITE ALLFHPER,"%"
IF $Y>(IOSL-4)
DO PG
IF EX=U
QUIT
+10 GOTO END
QUIT
+11 ;
N2 ;find Communications 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 ;
PG ;
+1 IF IOST?1"C".E
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
IF 'Y
SET EX=U
QUIT
+2 DO HDR
QUIT
HDR ;Header
+1 if $Y
WRITE @IOF
WRITE !,NAME,?30,"MONITOR BRIEF REPORT"
WRITE !,FHNDT,?60,"Page: "
SET PG=PG+1
WRITE PG,!!
+2 WRITE "Admission",?13,"Patient",?39,"SSN",?45,"Monitor?",?56,"Discharge"
+3 WRITE !
FOR Z=1:1:79
WRITE "="
+4 QUIT
