A1B2OSR1 ;ALB/AAS - ODS SUMMARY REPORT - COLLECT DATA ; 11-JAN-91
;;Version 1.55 (local for MAS v5 sites);;
;
K ^UTILITY($J)
D DATA Q
;
DATA ; -- collect admission data
S A=A1B2BDT-.00001
F I=A:0 S A=$O(^A1B2(11500.2,"B",A)) Q:'A!(A>(A1B2EDT+.9)) F M=0:0 S M=$O(^A1B2(11500.2,"B",A,M)) Q:'M I M,$D(^A1B2(11500.2,M,0)) S N=^(0) D FAC,ADM
;
; --collect discharge data
S D=A1B2BDT-.00001
F I=D:0 S D=$O(^A1B2(11500.2,"ADS",D)) Q:'D!(D>(A1B2EDT+.9)) F M=0:0 S M=$O(^A1B2(11500.2,"ADS",D,M)) Q:'M I M,$D(^A1B2(11500.2,M,0)) S N=^(0) D FAC,DIS
;
; -- collect patients remaining
S P=""
F I=0:0 S P=$O(^A1B2(11500.2,"B",P)) Q:'P!(P>(A1B2EDT+.9)) F M=0:0 S M=$O(^A1B2(11500.2,"B",P,M)) Q:'M I M,$D(^A1B2(11500.2,M,0)) S N=^(0) D FAC I $S($P(N,"^",6)="":1,($P(N,"^",6)>(A1B2EDT+.9)):1,1:0) D PTRM
;
; -- collect data on VA patients transfered to other facilities
S T=A1B2BDT-.0001
F I=T:0 S T=$O(^A1B2(11500.3,"B",T)) Q:'T!(T>(A1B2EDT+.9)) F M=0:0 S M=$O(^A1B2(11500.3,"B",T,M)) Q:'M I M,$D(^A1B2(11500.3,M,0)) S N=^(0) D FAC,TRF
Q
;
ADM ; -- count total admissions
Q:FAC=""!('A1B2CHK)
S DFN=$P(N,"^",2) Q:'DFN!('$P(N,"^",15))
S BOS=$S('DFN:"",'$D(^A1B2(11500.1,DFN,0)):"",1:$P(^(0),"^",4))
S SPC=$S('$P(N,"^",3):"",'$D(^DIC(42.4,$P(N,"^",3),0)):"",1:$P(^(0),"^",3))
S:'$D(^UTILITY($J,"ODS-ADM",FAC)) ^(FAC)=0 S ^(FAC)=^(FAC)+1
S:'$D(^UTILITY($J,"ODS-ADM-NAT")) ^("ODS-ADM-NAT")=0 S ^("ODS-ADM-NAT")=^("ODS-ADM-NAT")+1
;
; -- count unique admissions
I '$D(^UTILITY($J,"ODS-PT-ADM",DFN,FAC)) S:'$D(^UTILITY($J,"ODS-UNQ-ADM",FAC)) ^(FAC)=0 S ^(FAC)=^(FAC)+1
I '$D(^UTILITY($J,"ODS-PT-ADM",DFN)) S:'$D(^UTILITY($J,"ODS-UNQ-ADM-NAT")) ^("ODS-UNQ-ADM-NAT")=0 S ^("ODS-UNQ-ADM-NAT")=^("ODS-UNQ-ADM-NAT")+1
;
; -- count unique admssions by branch of service
I BOS]"",'$D(^UTILITY($J,"ODS-PT-ADM-BOS",BOS,DFN,FAC)) S:'$D(^UTILITY($J,"ODS-UNQA-BOS",FAC,BOS)) ^(BOS)=0 S ^(BOS)=^(BOS)+1
I BOS]"",'$D(^UTILITY($J,"ODS-PT-ADM-BOS",BOS,DFN)) S:'$D(^UTILITY($J,"ODS-UNQA-BOS-NAT",BOS)) ^(BOS)=0 S ^(BOS)=^(BOS)+1
;
; -- count unique admissions by specialty
I SPC]"",'$D(^UTILITY($J,"ODS-PT-ADM-SPC",SPC,DFN,FAC)) S:'$D(^UTILITY($J,"ODS-UNQA-SPC",FAC,SPC)) ^(SPC)=0 S ^(SPC)=^(SPC)+1
I SPC]"",'$D(^UTILITY($J,"ODS-PT-ADM-SPC",SPC,DFN)) S:'$D(^UTILITY($J,"ODS-UNQA-SPC-NAT",SPC)) ^(SPC)=0 S ^(SPC)=^(SPC)+1
;
; - store unique indicator
S ^UTILITY($J,"ODS-PT-ADM",DFN,FAC)=""
I BOS]"" S ^UTILITY($J,"ODS-PT-ADM-BOS",BOS,DFN,FAC)=""
I SPC]"" S ^UTILITY($J,"ODS-PT-ADM-SPC",SPC,DFN,FAC)=""
Q
;
DIS ; -- count total discharges
Q:FAC=""!('$P(N,"^",15))!('A1B2CHK)
S:'$D(^UTILITY($J,"ODS-DIS",FAC)) ^(FAC)=0 S ^(FAC)=^(FAC)+1
S:'$D(^UTILITY($J,"ODS-DIS-NAT")) ^("ODS-DIS-NAT")=0 S ^("ODS-DIS-NAT")=("ODS-DIS-NAT")+1
Q:'$P(N,"^",11)
; -- count transfers to non-va facilities
S:'$D(^UTILITY($J,"ODS-TRF-NVA",FAC)) ^(FAC)=0 S ^(FAC)=^(FAC)+1
S:'$D(^UTILITY($J,"ODS-TRF-NVA-NAT")) ^("ODS-TRF-NVA-NAT")=0 S ^("ODS-TRF-NVA-NAT")=^("ODS-TRF-NVA-NAT")+1
Q
;
PTRM ; -- count patients remaining
Q:FAC=""!('$P(N,"^",15))!('A1B2CHK)
S:'$D(^UTILITY($J,"ODS-PTRM",FAC)) ^(FAC)=0 S ^(FAC)=^(FAC)+1
S:'$D(^UTILITY($J,"ODS-PTRM-NAT")) ^("ODS-PTRM-NAT")=0 S ^("ODS-PTRM-NAT")=^("ODS-PTRM-NAT")+1
Q
;
TRF ; -- count patient transfers
Q:FAC=""!('$P(N,"^",15))!($P(N,"^",11)="")!('A1B2CHK)
S TYP=$P(N,"^",11),SUBS=$S(TYP:"ODS-DISP-NVA",1:"ODS-DISP-VA")
S:'$D(^UTILITY($J,SUBS,FAC)) ^(FAC)=0 S ^(FAC)=^(FAC)+1
S SUBS=SUBS_"-NAT"
S:'$D(^UTILITY($J,SUBS)) ^(SUBS)=0 S ^(SUBS)=^(SUBS)+1
Q
;
FAC ; --set up facility number/name
S FAC=$P(N,"^",7) Q:FAC=""!('$P(N,"^",15))
S A1B2CHK=0,X=$S($D(A1B2NTY):$P(A1B2NTY,U,2),1:"")
I $S(X=""!(X="A"):1,X="R":$P(N,U,9)=A1B2VRG,X="V":$P(N,U,7)=A1B2FN,1:0) S A1B2CHK=1
Q:'A1B2CHK
I '$D(^UTILITY($J,"ODS-FAC",FAC)) S ^UTILITY($J,"ODS-FAC",FAC)=$P(N,"^",8)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HA1B2OSR1 3912 printed Dec 13, 2024@02:21:18 Page 2
A1B2OSR1 ;ALB/AAS - ODS SUMMARY REPORT - COLLECT DATA ; 11-JAN-91
+1 ;;Version 1.55 (local for MAS v5 sites);;
+2 ;
+3 KILL ^UTILITY($JOB)
+4 DO DATA
QUIT
+5 ;
DATA ; -- collect admission data
+1 SET A=A1B2BDT-.00001
+2 FOR I=A:0
SET A=$ORDER(^A1B2(11500.2,"B",A))
if 'A!(A>(A1B2EDT+.9))
QUIT
FOR M=0:0
SET M=$ORDER(^A1B2(11500.2,"B",A,M))
if 'M
QUIT
IF M
IF $DATA(^A1B2(11500.2,M,0))
SET N=^(0)
DO FAC
DO ADM
+3 ;
+4 ; --collect discharge data
+5 SET D=A1B2BDT-.00001
+6 FOR I=D:0
SET D=$ORDER(^A1B2(11500.2,"ADS",D))
if 'D!(D>(A1B2EDT+.9))
QUIT
FOR M=0:0
SET M=$ORDER(^A1B2(11500.2,"ADS",D,M))
if 'M
QUIT
IF M
IF $DATA(^A1B2(11500.2,M,0))
SET N=^(0)
DO FAC
DO DIS
+7 ;
+8 ; -- collect patients remaining
+9 SET P=""
+10 FOR I=0:0
SET P=$ORDER(^A1B2(11500.2,"B",P))
if 'P!(P>(A1B2EDT+.9))
QUIT
FOR M=0:0
SET M=$ORDER(^A1B2(11500.2,"B",P,M))
if 'M
QUIT
IF M
IF $DATA(^A1B2(11500.2,M,0))
SET N=^(0)
DO FAC
IF $SELECT($PIECE(N,"^",6)="":1,($PIECE(N,"^",6)>(A1B2EDT+.9)):1,1:0)
DO PTRM
+11 ;
+12 ; -- collect data on VA patients transfered to other facilities
+13 SET T=A1B2BDT-.0001
+14 FOR I=T:0
SET T=$ORDER(^A1B2(11500.3,"B",T))
if 'T!(T>(A1B2EDT+.9))
QUIT
FOR M=0:0
SET M=$ORDER(^A1B2(11500.3,"B",T,M))
if 'M
QUIT
IF M
IF $DATA(^A1B2(11500.3,M,0))
SET N=^(0)
DO FAC
DO TRF
+15 QUIT
+16 ;
ADM ; -- count total admissions
+1 if FAC=""!('A1B2CHK)
QUIT
+2 SET DFN=$PIECE(N,"^",2)
if 'DFN!('$PIECE(N,"^",15))
QUIT
+3 SET BOS=$SELECT('DFN:"",'$DATA(^A1B2(11500.1,DFN,0)):"",1:$PIECE(^(0),"^",4))
+4 SET SPC=$SELECT('$PIECE(N,"^",3):"",'$DATA(^DIC(42.4,$PIECE(N,"^",3),0)):"",1:$PIECE(^(0),"^",3))
+5 if '$DATA(^UTILITY($JOB,"ODS-ADM",FAC))
SET ^(FAC)=0
SET ^(FAC)=^(FAC)+1
+6 if '$DATA(^UTILITY($JOB,"ODS-ADM-NAT"))
SET ^("ODS-ADM-NAT")=0
SET ^("ODS-ADM-NAT")=^("ODS-ADM-NAT")+1
+7 ;
+8 ; -- count unique admissions
+9 IF '$DATA(^UTILITY($JOB,"ODS-PT-ADM",DFN,FAC))
if '$DATA(^UTILITY($JOB,"ODS-UNQ-ADM",FAC))
SET ^(FAC)=0
SET ^(FAC)=^(FAC)+1
+10 IF '$DATA(^UTILITY($JOB,"ODS-PT-ADM",DFN))
if '$DATA(^UTILITY($JOB,"ODS-UNQ-ADM-NAT"))
SET ^("ODS-UNQ-ADM-NAT")=0
SET ^("ODS-UNQ-ADM-NAT")=^("ODS-UNQ-ADM-NAT")+1
+11 ;
+12 ; -- count unique admssions by branch of service
+13 IF BOS]""
IF '$DATA(^UTILITY($JOB,"ODS-PT-ADM-BOS",BOS,DFN,FAC))
if '$DATA(^UTILITY($JOB,"ODS-UNQA-BOS",FAC,BOS))
SET ^(BOS)=0
SET ^(BOS)=^(BOS)+1
+14 IF BOS]""
IF '$DATA(^UTILITY($JOB,"ODS-PT-ADM-BOS",BOS,DFN))
if '$DATA(^UTILITY($JOB,"ODS-UNQA-BOS-NAT",BOS))
SET ^(BOS)=0
SET ^(BOS)=^(BOS)+1
+15 ;
+16 ; -- count unique admissions by specialty
+17 IF SPC]""
IF '$DATA(^UTILITY($JOB,"ODS-PT-ADM-SPC",SPC,DFN,FAC))
if '$DATA(^UTILITY($JOB,"ODS-UNQA-SPC",FAC,SPC))
SET ^(SPC)=0
SET ^(SPC)=^(SPC)+1
+18 IF SPC]""
IF '$DATA(^UTILITY($JOB,"ODS-PT-ADM-SPC",SPC,DFN))
if '$DATA(^UTILITY($JOB,"ODS-UNQA-SPC-NAT",SPC))
SET ^(SPC)=0
SET ^(SPC)=^(SPC)+1
+19 ;
+20 ; - store unique indicator
+21 SET ^UTILITY($JOB,"ODS-PT-ADM",DFN,FAC)=""
+22 IF BOS]""
SET ^UTILITY($JOB,"ODS-PT-ADM-BOS",BOS,DFN,FAC)=""
+23 IF SPC]""
SET ^UTILITY($JOB,"ODS-PT-ADM-SPC",SPC,DFN,FAC)=""
+24 QUIT
+25 ;
DIS ; -- count total discharges
+1 if FAC=""!('$PIECE(N,"^",15))!('A1B2CHK)
QUIT
+2 if '$DATA(^UTILITY($JOB,"ODS-DIS",FAC))
SET ^(FAC)=0
SET ^(FAC)=^(FAC)+1
+3 if '$DATA(^UTILITY($JOB,"ODS-DIS-NAT"))
SET ^("ODS-DIS-NAT")=0
SET ^("ODS-DIS-NAT")=("ODS-DIS-NAT")+1
+4 if '$PIECE(N,"^",11)
QUIT
+5 ; -- count transfers to non-va facilities
+6 if '$DATA(^UTILITY($JOB,"ODS-TRF-NVA",FAC))
SET ^(FAC)=0
SET ^(FAC)=^(FAC)+1
+7 if '$DATA(^UTILITY($JOB,"ODS-TRF-NVA-NAT"))
SET ^("ODS-TRF-NVA-NAT")=0
SET ^("ODS-TRF-NVA-NAT")=^("ODS-TRF-NVA-NAT")+1
+8 QUIT
+9 ;
PTRM ; -- count patients remaining
+1 if FAC=""!('$PIECE(N,"^",15))!('A1B2CHK)
QUIT
+2 if '$DATA(^UTILITY($JOB,"ODS-PTRM",FAC))
SET ^(FAC)=0
SET ^(FAC)=^(FAC)+1
+3 if '$DATA(^UTILITY($JOB,"ODS-PTRM-NAT"))
SET ^("ODS-PTRM-NAT")=0
SET ^("ODS-PTRM-NAT")=^("ODS-PTRM-NAT")+1
+4 QUIT
+5 ;
TRF ; -- count patient transfers
+1 if FAC=""!('$PIECE(N,"^",15))!($PIECE(N,"^",11)="")!('A1B2CHK)
QUIT
+2 SET TYP=$PIECE(N,"^",11)
SET SUBS=$SELECT(TYP:"ODS-DISP-NVA",1:"ODS-DISP-VA")
+3 if '$DATA(^UTILITY($JOB,SUBS,FAC))
SET ^(FAC)=0
SET ^(FAC)=^(FAC)+1
+4 SET SUBS=SUBS_"-NAT"
+5 if '$DATA(^UTILITY($JOB,SUBS))
SET ^(SUBS)=0
SET ^(SUBS)=^(SUBS)+1
+6 QUIT
+7 ;
FAC ; --set up facility number/name
+1 SET FAC=$PIECE(N,"^",7)
if FAC=""!('$PIECE(N,"^",15))
QUIT
+2 SET A1B2CHK=0
SET X=$SELECT($DATA(A1B2NTY):$PIECE(A1B2NTY,U,2),1:"")
+3 IF $SELECT(X=""!(X="A"):1,X="R":$PIECE(N,U,9)=A1B2VRG,X="V":$PIECE(N,U,7)=A1B2FN,1:0)
SET A1B2CHK=1
+4 if 'A1B2CHK
QUIT
+5 IF '$DATA(^UTILITY($JOB,"ODS-FAC",FAC))
SET ^UTILITY($JOB,"ODS-FAC",FAC)=$PIECE(N,"^",8)
+6 QUIT
