- DGPMBSR2 ;ALB/LM - COLLECT REMAINING TOTALS FOR BED STATUS; 16 JAN 91
- ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
- ;
- 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 ;
- DGPMBSR2 ;ALB/LM - COLLECT REMAINING TOTALS FOR BED STATUS; 16 JAN 91
- +1 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
- +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 ;
