DGPMBSR4.m

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