DGPMBSR4 ;ALB/LM - STORE NEW TREATING SPECIALITY NODES; 16 JAN 91
;;5.3;Registration;**85**;Aug 13, 1993
;
; Storing in the Medical Center Division File, Treating Specialty Census Data
Q:RD<TSRI ; Quit if report date is less than TSR Initialization date
;
I TSRI>RD Q ; If TSR Initialization date is after report date quit
A D Q
S DV=0 F I=0:0 S DV=$O(^DG(40.8,DV)) Q:'DV S T=0 F I1=0:0 S T=$O(^DG(40.8,DV,"TS",T)) Q:'T D TSET
;
Q K DV,I2,X Q
;
TSET F I2="DGTP","DGTI","DGTU","DGTA","DGTV","DGT6","DGTF","DGS","DGSN","DGS1","DGSN1","DGTOD","DGTAS" S X(I2)=$S($D(^UTILITY(I2,$J,DV,T)):^(T),1:0)
S:'X("DGS") $P(X("DGS"),U,1)=RD
F I2=5,6,8,12,13,14,15,16,17,18,19,20,21,22,23,24,26,27,28,29 S $P(X("DGS"),"^",I2)=$P(X("DGS"),"^",I2)+$P(X("DGSN"),"^",I2)
S $P(X("DGS"),"^",7)=$P(X("DGS"),"^",5)+$P(X("DGS"),"^",2) ; Patients Remaining [Cum] = Discharge-Total [Cum] + Patients Remaining
S X=$S(REM:+X("DGTI"),1:$P(X("DGS"),"^",2)+$P(X("DGSN"),"^",28)-$P(X("DGSN"),"^",24)) ; TS Inpatients OR Patients Remaining + Gains-Total [Cum] - Losses-Total [Cum]
S $P(X("DGS"),"^",2)=+X ; Patients Remaining
S $P(X("DGS"),"^",3)=$P(X("DGS"),"^",3)+X ; Patient Days of Care [Cum]
S $P(X("DGS"),"^",3)=$P(X("DGS"),"^",3)+X("DGTOD") ; Cum Patient Days of Care to include oneday admissions
S $P(X("DGS1"),"^",1)=+X("DGTF") ; Females Remaining
S $P(X("DGS1"),"^",3)=+X("DGT6") ; 65 and Over Remaining
S $P(X("DGS1"),"^",4)=+X("DGTV") ; Vietnam Era Remaining
S $P(X("DGS1"),"^",5)=+X("DGTP") ; Pass Patients Remaining
S $P(X("DGS1"),"^",6)=+X("DGTA") ; AA Remaining
S $P(X("DGS1"),"^",7)=+X("DGTU") ; UA Remaining
S $P(X("DGS1"),"^",8)=+X("DGTAS") ; ASIH Remaining
S $P(X("DGS1"),"^",11)=$P(X("DGS1"),"^",11)+X("DGTOD") ; One Day Discharges
S $P(X("DGS"),"^",9)=$P(X("DGS"),"^",9)+$P(X("DGS1"),"^",5) ; Pass Days [Cum] + AA<96
S $P(X("DGS"),"^",10)=$P(X("DGS"),"^",10)+$P(X("DGS1"),"^",6) ; AA Days [Cum] + AA
S $P(X("DGS"),"^",11)=$P(X("DGS"),"^",11)+$P(X("DGS1"),"^",7) ; UA Days [Cum] + UA
S:'$D(^DG(40.8,DV,"TS",0)) ^(0)="^40.806P^^"
S:'$D(^DG(40.8,DV,"TS",T,0)) X=^DG(40.8,DV,"TS",0),$P(X,"^",3)=T,$P(X,"^",4)=$P(X,"^",4)+1,^DG(40.8,DV,"TS",0)=X,^DG(40.8,DV,"TS","B",T,T)=""
S:'$D(^DG(40.8,DV,"TS",T,"C",0)) ^(0)="^40.807D^^"
S:'$D(^DG(40.8,DV,"TS",T,"C",RD,0)) X=^DG(40.8,DV,"TS",T,"C",0),$P(X,"^",3)=RD,$P(X,"^",4)=$P(X,"^",4)+1,^DG(40.8,DV,"TS",T,"C",0)=X
S ^DG(40.8,DV,"TS",T,"C",RD,0)=X("DGS")
S ^DG(40.8,DV,"TS",T,"C",RD,1)=X("DGS1")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMBSR4 2519 printed Dec 13, 2024@02:49:21 Page 2
DGPMBSR4 ;ALB/LM - STORE NEW TREATING SPECIALITY NODES; 16 JAN 91
+1 ;;5.3;Registration;**85**;Aug 13, 1993
+2 ;
+3 ; Storing in the Medical Center Division File, Treating Specialty Census Data
+4 ; Quit if report date is less than TSR Initialization date
if RD<TSRI
QUIT
+5 ;
+6 ; If TSR Initialization date is after report date quit
IF TSRI>RD
QUIT
A DO Q
+1 SET DV=0
FOR I=0:0
SET DV=$ORDER(^DG(40.8,DV))
if 'DV
QUIT
SET T=0
FOR I1=0:0
SET T=$ORDER(^DG(40.8,DV,"TS",T))
if 'T
QUIT
DO TSET
+2 ;
Q KILL DV,I2,X
QUIT
+1 ;
TSET FOR I2="DGTP","DGTI","DGTU","DGTA","DGTV","DGT6","DGTF","DGS","DGSN","DGS1","DGSN1","DGTOD","DGTAS"
SET X(I2)=$SELECT($DATA(^UTILITY(I2,$JOB,DV,T)):^(T),1:0)
+1 if 'X("DGS")
SET $PIECE(X("DGS"),U,1)=RD
+2 FOR I2=5,6,8,12,13,14,15,16,17,18,19,20,21,22,23,24,26,27,28,29
SET $PIECE(X("DGS"),"^",I2)=$PIECE(X("DGS"),"^",I2)+$PIECE(X("DGSN"),"^",I2)
+3 ; Patients Remaining [Cum] = Discharge-Total [Cum] + Patients Remaining
SET $PIECE(X("DGS"),"^",7)=$PIECE(X("DGS"),"^",5)+$PIECE(X("DGS"),"^",2)
+4 ; TS Inpatients OR Patients Remaining + Gains-Total [Cum] - Losses-Total [Cum]
SET X=$SELECT(REM:+X("DGTI"),1:$PIECE(X("DGS"),"^",2)+$PIECE(X("DGSN"),"^",28)-$PIECE(X("DGSN"),"^",24))
+5 ; Patients Remaining
SET $PIECE(X("DGS"),"^",2)=+X
+6 ; Patient Days of Care [Cum]
SET $PIECE(X("DGS"),"^",3)=$PIECE(X("DGS"),"^",3)+X
+7 ; Cum Patient Days of Care to include oneday admissions
SET $PIECE(X("DGS"),"^",3)=$PIECE(X("DGS"),"^",3)+X("DGTOD")
+8 ; Females Remaining
SET $PIECE(X("DGS1"),"^",1)=+X("DGTF")
+9 ; 65 and Over Remaining
SET $PIECE(X("DGS1"),"^",3)=+X("DGT6")
+10 ; Vietnam Era Remaining
SET $PIECE(X("DGS1"),"^",4)=+X("DGTV")
+11 ; Pass Patients Remaining
SET $PIECE(X("DGS1"),"^",5)=+X("DGTP")
+12 ; AA Remaining
SET $PIECE(X("DGS1"),"^",6)=+X("DGTA")
+13 ; UA Remaining
SET $PIECE(X("DGS1"),"^",7)=+X("DGTU")
+14 ; ASIH Remaining
SET $PIECE(X("DGS1"),"^",8)=+X("DGTAS")
+15 ; One Day Discharges
SET $PIECE(X("DGS1"),"^",11)=$PIECE(X("DGS1"),"^",11)+X("DGTOD")
+16 ; Pass Days [Cum] + AA<96
SET $PIECE(X("DGS"),"^",9)=$PIECE(X("DGS"),"^",9)+$PIECE(X("DGS1"),"^",5)
+17 ; AA Days [Cum] + AA
SET $PIECE(X("DGS"),"^",10)=$PIECE(X("DGS"),"^",10)+$PIECE(X("DGS1"),"^",6)
+18 ; UA Days [Cum] + UA
SET $PIECE(X("DGS"),"^",11)=$PIECE(X("DGS"),"^",11)+$PIECE(X("DGS1"),"^",7)
+19 if '$DATA(^DG(40.8,DV,"TS",0))
SET ^(0)="^40.806P^^"
+20 if '$DATA(^DG(40.8,DV,"TS",T,0))
SET X=^DG(40.8,DV,"TS",0)
SET $PIECE(X,"^",3)=T
SET $PIECE(X,"^",4)=$PIECE(X,"^",4)+1
SET ^DG(40.8,DV,"TS",0)=X
SET ^DG(40.8,DV,"TS","B",T,T)=""
+21 if '$DATA(^DG(40.8,DV,"TS",T,"C",0))
SET ^(0)="^40.807D^^"
+22 if '$DATA(^DG(40.8,DV,"TS",T,"C",RD,0))
SET X=^DG(40.8,DV,"TS",T,"C",0)
SET $PIECE(X,"^",3)=RD
SET $PIECE(X,"^",4)=$PIECE(X,"^",4)+1
SET ^DG(40.8,DV,"TS",T,"C",0)=X
+23 SET ^DG(40.8,DV,"TS",T,"C",RD,0)=X("DGS")
+24 SET ^DG(40.8,DV,"TS",T,"C",RD,1)=X("DGS1")
+25 QUIT
