DGPMBSR1 ;ALB/LM - BED STATUS REPORT RECALCULATION CONT.; 16 JAN 91
;;5.3;Registration;**85**;Aug 13, 1993
;
A S DIE="^DG(43,",DA=1,DR="53///"_RD D ^DIE K DA,DIE,DR ; Date when recalc up to
S W=0 F I=0:0 S W=$O(^DIC(42,W)) Q:'W D SET
S D=0 F I=0:0 S D=$O(^DG(40.8,D)) Q:'D S ^UTILITY("DGD",$J,D)=$S($D(^DG(40.8,D,"CEN",PD,0)):$P(^(0),"^",12),1:0),^UTILITY("DGDN",$J,D)="" S T=0 F I1=0:0 S T=$O(^DG(40.8,D,"TS",T)) Q:'T D TSET
K I,I1,T,W,D
D ^DGPMGLG
Q
;
SET S X=$S($D(^DG(41.9,W,"C",PD,0)):^(0),1:""),X=RD_"^"_$P(X,"^",2,99)
S:$E(PD,4,7)="0930" X=$P(X,"^",1,2) ; New fiscal year
S ^UTILITY("DGC",$J,W)=X ; Census
S ^UTILITY("DGCN",$J,W)="" ; New census
S ^UTILITY("DGOD",$J,+W)=0 ; One Day Admissions
S X1=$S($D(^DG(41.9,W,"C",PD,1)):$P(^(1),"^",1,10),1:"")
S ^UTILITY("DGR",$J,W)=X1 ; Remaining
S ^UTILITY("DGRN",$J,W)="" ; New remaining (one node)
S ^UTILITY("DGFR",$J,+W)=0 ; Female Patients Remaining
S ^UTILITY("DG6",$J,+W)=0 ; Bed Occupants 65 & Over
S ^UTILITY("DGVN",$J,+W)=0 ; Bed Occupants VN
S ^UTILITY("DGPS",$J,+W)=$S('REM:+$P(X1,"^",5),1:0) ; Pass
S ^UTILITY("DGAA",$J,+W)=$S('REM:+$P(X1,"^",6),1:0) ; Auth absense
S ^UTILITY("DGUA",$J,+W)=$S('REM:+$P(X1,"^",7),1:0) ; Unauth absense
S:'REM ^UTILITY("DGAS",$J,+W)=+$P(X1,"^",8) ; ASIH
S:REM ^UTILITY("DGIP",$J,+W)=0 ; if count pt. remaining
CEN S ^DG(41.9,W,"C",RD,0)=RD_"^"_$P(^UTILITY("DGC",$J,W),"^",2,99)
S:'$D(^DG(41.9,W,0))#2 ^(0)=W,^DG(41.9,"B",W,W)="",$P(^(0),"^",4)=$P(^DG(41.9,0),"^",4)+1,$P(^(0),"^",3)=RD
S:'$D(^DG(41.9,W,"C",0))#2 ^(0)="^41.91DA^^"
Q
;
TSET I TSRI>RD Q ; If TSR Initialization date is greater than report date quit
S X=$S($D(^DG(40.8,D,"TS",T,"C",PD,0)):^(0),1:""),X=RD_"^"_$P(X,"^",2,99)
I RD=TSRI,$P(X,U,2)']"" S X=RD_"^"_$P(^DG(40.8,D,"TS",T,0),"^",3)
S:$E(PD,4,7)="0930" X=$P(X,"^",1,2)
S ^UTILITY("DGS",$J,+D,+T)=X ; Treating Specialty census
S ^UTILITY("DGSN",$J,+D,+T)="" ; Treating Specialty new census
S ^UTILITY("DGTOD",$J,+D,+T)=0 ; One Day Admissions
S X1=$S($D(^DG(40.8,D,"TS",T,"C",PD,1)):$P(^(1),"^",1,10),1:"")
S ^UTILITY("DGS1",$J,+D,+T)=X1 ; Treating Specialty remaining
S ^UTILITY("DGSN1",$J,+D,+T)="" ; Treating Specialty new remaining (one node)
S ^UTILITY("DGTF",$J,+D,+T)=0 ; Female Patients Remaining
S ^UTILITY("DGT6",$J,+D,+T)=0 ; Bed Occupants 65 & Over
S ^UTILITY("DGTV",$J,+D,+T)=0 ; Bed Occupants VN
S ^UTILITY("DGTP",$J,+D,+T)=$S('REM:+$P(X1,"^",5),1:0) ; Treating Specialty Pass
S ^UTILITY("DGTA",$J,+D,+T)=$S('REM:+$P(X1,"^",6),1:0) ; Treating Specialty Auth absense
S ^UTILITY("DGTU",$J,+D,+T)=$S('REM:+$P(X1,"^",7),1:0) ; Treating Specialty Unauth absense
S:'REM ^UTILITY("DGTAS",$J,+D,+T)=+$P(X1,"^",8) ; Treating Specialty ASIH
S:REM ^UTILITY("DGTI",$J,+D,+T)=0 ; if count pt. remaining
TCEN S ^DG(40.8,D,"TS",T,"C",RD,0)=RD_"^"_$P(^UTILITY("DGS",$J,D,T),"^",2,99),^DG(40.8,D,"TS",T,"C","B",RD,RD)=""
S:'$D(^DG(40.8,D,"TS",T,0))#2 ^(0)=T,^DG(40.8,D,"TS","B",T,T)=""
S:'$D(^DG(40.8,D,"TS",T,"C",0))#2 ^(0)="^40.807D^^",^DG(40.8,D,"TS",T,"C","B",T,T)=""
Q
;
UTIL ; Utility Nodes
; DGD=Monthly Planned Dom. (yesterday) ;
; DGDN=Monthly Planned Dom. (new) ;
; DGC=Zero Node Census file (yesterday) ;
; DGCN=Zero Node Census file (new) ;
; DGR=One Node Census file (yesterday) ;
; DGRN=One Node Census file (new) ;
; DGS=Treating Specialty (yesterday) ;
; DGSN=Treating Specialty (new) ;
; DGS1=Treating Specialty One Node (yesterday) ;
; DGSN1=Treating Specialty One Node (new) ;
;
VAR ; RC=ReCalc from date ; YD=YesterDay ; RD=Report Date ;
; BS=Bed Status ; GL=G&L ; REM=Recalc patient days ;
; PD=Previous Day ; W=Ward ; D=Division ; T=Treating Specialty
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMBSR1 3783 printed Apr 09, 2024@21:42:33 Page 2
DGPMBSR1 ;ALB/LM - BED STATUS REPORT RECALCULATION CONT.; 16 JAN 91
+1 ;;5.3;Registration;**85**;Aug 13, 1993
+2 ;
A ; Date when recalc up to
SET DIE="^DG(43,"
SET DA=1
SET DR="53///"_RD
DO ^DIE
KILL DA,DIE,DR
+1 SET W=0
FOR I=0:0
SET W=$ORDER(^DIC(42,W))
if 'W
QUIT
DO SET
+2 SET D=0
FOR I=0:0
SET D=$ORDER(^DG(40.8,D))
if 'D
QUIT
SET ^UTILITY("DGD",$JOB,D)=$SELECT($DATA(^DG(40.8,D,"CEN",PD,0)):$PIECE(^(0),"^",12),1:0)
SET ^UTILITY("DGDN",$JOB,D)=""
SET T=0
FOR I1=0:0
SET T=$ORDER(^DG(40.8,D,"TS",T))
if 'T
QUIT
DO TSET
+3 KILL I,I1,T,W,D
+4 DO ^DGPMGLG
+5 QUIT
+6 ;
SET SET X=$SELECT($DATA(^DG(41.9,W,"C",PD,0)):^(0),1:"")
SET X=RD_"^"_$PIECE(X,"^",2,99)
+1 ; New fiscal year
if $EXTRACT(PD,4,7)="0930"
SET X=$PIECE(X,"^",1,2)
+2 ; Census
SET ^UTILITY("DGC",$JOB,W)=X
+3 ; New census
SET ^UTILITY("DGCN",$JOB,W)=""
+4 ; One Day Admissions
SET ^UTILITY("DGOD",$JOB,+W)=0
+5 SET X1=$SELECT($DATA(^DG(41.9,W,"C",PD,1)):$PIECE(^(1),"^",1,10),1:"")
+6 ; Remaining
SET ^UTILITY("DGR",$JOB,W)=X1
+7 ; New remaining (one node)
SET ^UTILITY("DGRN",$JOB,W)=""
+8 ; Female Patients Remaining
SET ^UTILITY("DGFR",$JOB,+W)=0
+9 ; Bed Occupants 65 & Over
SET ^UTILITY("DG6",$JOB,+W)=0
+10 ; Bed Occupants VN
SET ^UTILITY("DGVN",$JOB,+W)=0
+11 ; Pass
SET ^UTILITY("DGPS",$JOB,+W)=$SELECT('REM:+$PIECE(X1,"^",5),1:0)
+12 ; Auth absense
SET ^UTILITY("DGAA",$JOB,+W)=$SELECT('REM:+$PIECE(X1,"^",6),1:0)
+13 ; Unauth absense
SET ^UTILITY("DGUA",$JOB,+W)=$SELECT('REM:+$PIECE(X1,"^",7),1:0)
+14 ; ASIH
if 'REM
SET ^UTILITY("DGAS",$JOB,+W)=+$PIECE(X1,"^",8)
+15 ; if count pt. remaining
if REM
SET ^UTILITY("DGIP",$JOB,+W)=0
CEN SET ^DG(41.9,W,"C",RD,0)=RD_"^"_$PIECE(^UTILITY("DGC",$JOB,W),"^",2,99)
+1 if '$DATA(^DG(41.9,W,0))#2
SET ^(0)=W
SET ^DG(41.9,"B",W,W)=""
SET $PIECE(^(0),"^",4)=$PIECE(^DG(41.9,0),"^",4)+1
SET $PIECE(^(0),"^",3)=RD
+2 if '$DATA(^DG(41.9,W,"C",0))#2
SET ^(0)="^41.91DA^^"
+3 QUIT
+4 ;
TSET ; If TSR Initialization date is greater than report date quit
IF TSRI>RD
QUIT
+1 SET X=$SELECT($DATA(^DG(40.8,D,"TS",T,"C",PD,0)):^(0),1:"")
SET X=RD_"^"_$PIECE(X,"^",2,99)
+2 IF RD=TSRI
IF $PIECE(X,U,2)']""
SET X=RD_"^"_$PIECE(^DG(40.8,D,"TS",T,0),"^",3)
+3 if $EXTRACT(PD,4,7)="0930"
SET X=$PIECE(X,"^",1,2)
+4 ; Treating Specialty census
SET ^UTILITY("DGS",$JOB,+D,+T)=X
+5 ; Treating Specialty new census
SET ^UTILITY("DGSN",$JOB,+D,+T)=""
+6 ; One Day Admissions
SET ^UTILITY("DGTOD",$JOB,+D,+T)=0
+7 SET X1=$SELECT($DATA(^DG(40.8,D,"TS",T,"C",PD,1)):$PIECE(^(1),"^",1,10),1:"")
+8 ; Treating Specialty remaining
SET ^UTILITY("DGS1",$JOB,+D,+T)=X1
+9 ; Treating Specialty new remaining (one node)
SET ^UTILITY("DGSN1",$JOB,+D,+T)=""
+10 ; Female Patients Remaining
SET ^UTILITY("DGTF",$JOB,+D,+T)=0
+11 ; Bed Occupants 65 & Over
SET ^UTILITY("DGT6",$JOB,+D,+T)=0
+12 ; Bed Occupants VN
SET ^UTILITY("DGTV",$JOB,+D,+T)=0
+13 ; Treating Specialty Pass
SET ^UTILITY("DGTP",$JOB,+D,+T)=$SELECT('REM:+$PIECE(X1,"^",5),1:0)
+14 ; Treating Specialty Auth absense
SET ^UTILITY("DGTA",$JOB,+D,+T)=$SELECT('REM:+$PIECE(X1,"^",6),1:0)
+15 ; Treating Specialty Unauth absense
SET ^UTILITY("DGTU",$JOB,+D,+T)=$SELECT('REM:+$PIECE(X1,"^",7),1:0)
+16 ; Treating Specialty ASIH
if 'REM
SET ^UTILITY("DGTAS",$JOB,+D,+T)=+$PIECE(X1,"^",8)
+17 ; if count pt. remaining
if REM
SET ^UTILITY("DGTI",$JOB,+D,+T)=0
TCEN SET ^DG(40.8,D,"TS",T,"C",RD,0)=RD_"^"_$PIECE(^UTILITY("DGS",$JOB,D,T),"^",2,99)
SET ^DG(40.8,D,"TS",T,"C","B",RD,RD)=""
+1 if '$DATA(^DG(40.8,D,"TS",T,0))#2
SET ^(0)=T
SET ^DG(40.8,D,"TS","B",T,T)=""
+2 if '$DATA(^DG(40.8,D,"TS",T,"C",0))#2
SET ^(0)="^40.807D^^"
SET ^DG(40.8,D,"TS",T,"C","B",T,T)=""
+3 QUIT
+4 ;
UTIL ; Utility Nodes
+1 ; DGD=Monthly Planned Dom. (yesterday) ;
+2 ; DGDN=Monthly Planned Dom. (new) ;
+3 ; DGC=Zero Node Census file (yesterday) ;
+4 ; DGCN=Zero Node Census file (new) ;
+5 ; DGR=One Node Census file (yesterday) ;
+6 ; DGRN=One Node Census file (new) ;
+7 ; DGS=Treating Specialty (yesterday) ;
+8 ; DGSN=Treating Specialty (new) ;
+9 ; DGS1=Treating Specialty One Node (yesterday) ;
+10 ; DGSN1=Treating Specialty One Node (new) ;
+11 ;
VAR ; RC=ReCalc from date ; YD=YesterDay ; RD=Report Date ;
+1 ; BS=Bed Status ; GL=G&L ; REM=Recalc patient days ;
+2 ; PD=Previous Day ; W=Ward ; D=Division ; T=Treating Specialty
