- DGPMBSR4 ;ALB/LM - STORE NEW TREATING SPECIALITY NODES; 16 JAN 91
- ;;5.3;Registration;**85,1015**;Aug 13, 1993;Build 21
- ;
- ; 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
- DGPMBSR4 ;ALB/LM - STORE NEW TREATING SPECIALITY NODES; 16 JAN 91
- +1 ;;5.3;Registration;**85,1015**;Aug 13, 1993;Build 21
- +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