DGPMBSR2 ;ALB/LM - COLLECT REMAINING TOTALS FOR BED STATUS; 16 JAN 91
;;5.3;Registration;;Aug 13, 1993
;
A I $S('$D(RD):1,'RD:1,1:0) Q
S VAPRT=$S('$D(VAPRT):0,1:VAPRT),VACN=$S($D(VACN):VACN,1:0),X1=RD,X2=1 D C^%DTC S VATD=9999999.999999-X
D PR,FR,O65,VN
;
Q K CN,D,DB,DGSF,DGVT,DV,M,MW,MW1,MW2,MW2,P,PR,PR1,PRC,PRT,R,T,W,X,X1,X2,XX,XX1,XX2,XX3 D KVAR^VADPT30 Q
;
PR ; Patient's Remaining [Required]
I REM S DV=+DIV,VAPRC=1,DFN=0 F PR=0:0 S DFN=$O(^DGPM("C",DFN)) Q:'DFN S VABO=0 D VAR^VADPT30,BOS:VABO
Q
;
FR ; Females Remaining [Required]
S (VAPRC,DFN)=0
F PR=0:0 S DFN=$O(^DPT("ASX","F",DFN)) Q:'DFN I $O(^DGPM("ATID1",DFN,9999998-RD)) D VAR^VADPT30 D FR1
Q
FR1 I VAWD S DV=+DIV D DV:'DV
S:VAWD ^(+VAWD)=$S($D(^UTILITY("DGFR",$J,+VAWD)):^(+VAWD),1:0)+1
S:VATS ^(+VATS)=$S($D(^UTILITY("DGTF",$J,DV,+VATS)):^(+VATS),1:0)+1
Q
;
O65 ; Over 65 years old Remaining [Optional]
Q:'SF
S DGSF=RD\1-650000,(VAPRC,DB)=0
F PR=0:0 S DB=$O(^DPT("ADOB",DB)),DFN=0 Q:'DB!(DB>(DT-650000)) F PR1=0:0 S DFN=$O(^DPT("ADOB",DB,DFN)) Q:'DFN I $O(^DGPM("ATID1",DFN,9999998-RD)) D VAR^VADPT30 D O651
Q
O651 I VAWD S DV=+DIV D DV:'DV
S:VAWD ^(+VAWD)=$S($D(^UTILITY("DG6",$J,+VAWD)):^(+VAWD),1:0)+1
S:VATS ^(+VATS)=$S($D(^UTILITY("DGT6",$J,DV,+VATS)):^(+VATS),1:0)+1
Q
;
VN ; Vietnam Veteran's Remaining [Optional]
Q:'VN
S DGVT=$O(^DIC(21,"D",7,0)) Q:'DGVT
S (VAPRC,DFN)=0
F PR=0:0 S DFN=$O(^DPT("APOS",DGVT,DFN)) Q:'DFN I $O(^DGPM("ATID1",DFN,9999998-RD)) D VAR^VADPT30 D VN1
Q
;
VN1 I VAWD S DV=+DIV D DV:'DV
S:VAWD ^(+VAWD)=$S($D(^UTILITY("DGVN",$J,+VAWD)):^(+VAWD),1:0)+1
S:VATS ^(+VATS)=$S($D(^UTILITY("DGTV",$J,DV,+VATS)):^(+VATS),1:0)+1
Q
;
BOS ; Bed Occupant Status
S:$D(DGPMBO(VABO)) ^DIBT(+DGPMY,1,VAMV)=""
Q:VAPRT
S DV=+DIV D DV:'DV
S:VAWD X="DG"_$S(VABO=1:"PS",VABO=2:"AA",VABO=3:"UA",1:"IP")
S:VAWD ^(+VAWD)=$S($D(^UTILITY(X,$J,+VAWD)):^(+VAWD),1:0)+1
S:VATS X1="DGT"_$S(VABO=1:"O",VABO=2:"A",VABO=3:"U",1:"I")
S:VATS ^(+VATS)=$S($D(^UTILITY(X1,$J,DV,+VATS)):^(+VATS),1:0)+1
Q:VABO'=1
S:VAWD ^(+VAWD)=$S($D(^UTILITY("DGIP",$J,+VAWD)):^(+VAWD),1:0)+1
S:VATS ^(+VATS)=$S($D(^UTILITY("DGTI",$J,+DV,+VATS)):^(+VATS),1:0)+1
Q
;
DV S DV=$S($D(^DIC(42,+VAWD,0)):+$P(^(0),"^",11),1:0) S:'DV DV=+DIV Q
;
UTIL ; Utility Nodes
; DGAA=Authorized Absence ;
; DGUA=Unauthorized Absence ;
; DGPS=Pass ;
; DGIP=Inpatient (BO) ;
; DGVN=Vietnam ;
; DGFR=Female Remaining ;
; DG6=Over 65 ;
; DGTP=Treating Speciality Pass ;
; DGTI=Treating Speciality Inpatient ;
; DGTU=Treating Speciality UA ;
; DGTA=Treating Speciality AA ;
; DGTV=Treating Speciality Vietnam ;
; DGT6=Treating Speciality +65 ;
; DGTF=Treating Speciality Female ;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMBSR2 2776 printed Nov 22, 2024@17:59:19 Page 2
DGPMBSR2 ;ALB/LM - COLLECT REMAINING TOTALS FOR BED STATUS; 16 JAN 91
+1 ;;5.3;Registration;;Aug 13, 1993
+2 ;
A IF $SELECT('$DATA(RD):1,'RD:1,1:0)
QUIT
+1 SET VAPRT=$SELECT('$DATA(VAPRT):0,1:VAPRT)
SET VACN=$SELECT($DATA(VACN):VACN,1:0)
SET X1=RD
SET X2=1
DO C^%DTC
SET VATD=9999999.999999-X
+2 DO PR
DO FR
DO O65
DO VN
+3 ;
Q KILL CN,D,DB,DGSF,DGVT,DV,M,MW,MW1,MW2,MW2,P,PR,PR1,PRC,PRT,R,T,W,X,X1,X2,XX,XX1,XX2,XX3
DO KVAR^VADPT30
QUIT
+1 ;
PR ; Patient's Remaining [Required]
+1 IF REM
SET DV=+DIV
SET VAPRC=1
SET DFN=0
FOR PR=0:0
SET DFN=$ORDER(^DGPM("C",DFN))
if 'DFN
QUIT
SET VABO=0
DO VAR^VADPT30
if VABO
DO BOS
+2 QUIT
+3 ;
FR ; Females Remaining [Required]
+1 SET (VAPRC,DFN)=0
+2 FOR PR=0:0
SET DFN=$ORDER(^DPT("ASX","F",DFN))
if 'DFN
QUIT
IF $ORDER(^DGPM("ATID1",DFN,9999998-RD))
DO VAR^VADPT30
DO FR1
+3 QUIT
FR1 IF VAWD
SET DV=+DIV
if 'DV
DO DV
+1 if VAWD
SET ^(+VAWD)=$SELECT($DATA(^UTILITY("DGFR",$JOB,+VAWD)):^(+VAWD),1:0)+1
+2 if VATS
SET ^(+VATS)=$SELECT($DATA(^UTILITY("DGTF",$JOB,DV,+VATS)):^(+VATS),1:0)+1
+3 QUIT
+4 ;
O65 ; Over 65 years old Remaining [Optional]
+1 if 'SF
QUIT
+2 SET DGSF=RD\1-650000
SET (VAPRC,DB)=0
+3 FOR PR=0:0
SET DB=$ORDER(^DPT("ADOB",DB))
SET DFN=0
if 'DB!(DB>(DT-650000))
QUIT
FOR PR1=0:0
SET DFN=$ORDER(^DPT("ADOB",DB,DFN))
if 'DFN
QUIT
IF $ORDER(^DGPM("ATID1",DFN,9999998-RD))
DO VAR^VADPT30
DO O651
+4 QUIT
O651 IF VAWD
SET DV=+DIV
if 'DV
DO DV
+1 if VAWD
SET ^(+VAWD)=$SELECT($DATA(^UTILITY("DG6",$JOB,+VAWD)):^(+VAWD),1:0)+1
+2 if VATS
SET ^(+VATS)=$SELECT($DATA(^UTILITY("DGT6",$JOB,DV,+VATS)):^(+VATS),1:0)+1
+3 QUIT
+4 ;
VN ; Vietnam Veteran's Remaining [Optional]
+1 if 'VN
QUIT
+2 SET DGVT=$ORDER(^DIC(21,"D",7,0))
if 'DGVT
QUIT
+3 SET (VAPRC,DFN)=0
+4 FOR PR=0:0
SET DFN=$ORDER(^DPT("APOS",DGVT,DFN))
if 'DFN
QUIT
IF $ORDER(^DGPM("ATID1",DFN,9999998-RD))
DO VAR^VADPT30
DO VN1
+5 QUIT
+6 ;
VN1 IF VAWD
SET DV=+DIV
if 'DV
DO DV
+1 if VAWD
SET ^(+VAWD)=$SELECT($DATA(^UTILITY("DGVN",$JOB,+VAWD)):^(+VAWD),1:0)+1
+2 if VATS
SET ^(+VATS)=$SELECT($DATA(^UTILITY("DGTV",$JOB,DV,+VATS)):^(+VATS),1:0)+1
+3 QUIT
+4 ;
BOS ; Bed Occupant Status
+1 if $DATA(DGPMBO(VABO))
SET ^DIBT(+DGPMY,1,VAMV)=""
+2 if VAPRT
QUIT
+3 SET DV=+DIV
if 'DV
DO DV
+4 if VAWD
SET X="DG"_$SELECT(VABO=1:"PS",VABO=2:"AA",VABO=3:"UA",1:"IP")
+5 if VAWD
SET ^(+VAWD)=$SELECT($DATA(^UTILITY(X,$JOB,+VAWD)):^(+VAWD),1:0)+1
+6 if VATS
SET X1="DGT"_$SELECT(VABO=1:"O",VABO=2:"A",VABO=3:"U",1:"I")
+7 if VATS
SET ^(+VATS)=$SELECT($DATA(^UTILITY(X1,$JOB,DV,+VATS)):^(+VATS),1:0)+1
+8 if VABO'=1
QUIT
+9 if VAWD
SET ^(+VAWD)=$SELECT($DATA(^UTILITY("DGIP",$JOB,+VAWD)):^(+VAWD),1:0)+1
+10 if VATS
SET ^(+VATS)=$SELECT($DATA(^UTILITY("DGTI",$JOB,+DV,+VATS)):^(+VATS),1:0)+1
+11 QUIT
+12 ;
DV SET DV=$SELECT($DATA(^DIC(42,+VAWD,0)):+$PIECE(^(0),"^",11),1:0)
if 'DV
SET DV=+DIV
QUIT
+1 ;
UTIL ; Utility Nodes
+1 ; DGAA=Authorized Absence ;
+2 ; DGUA=Unauthorized Absence ;
+3 ; DGPS=Pass ;
+4 ; DGIP=Inpatient (BO) ;
+5 ; DGVN=Vietnam ;
+6 ; DGFR=Female Remaining ;
+7 ; DG6=Over 65 ;
+8 ; DGTP=Treating Speciality Pass ;
+9 ; DGTI=Treating Speciality Inpatient ;
+10 ; DGTU=Treating Speciality UA ;
+11 ; DGTA=Treating Speciality AA ;
+12 ; DGTV=Treating Speciality Vietnam ;
+13 ; DGT6=Treating Speciality +65 ;
+14 ; DGTF=Treating Speciality Female ;
