ADGAD3 ; IHS/ADC/PDW/ENM - A&D DISCHARGES ; [ 05/19/2000 10:29 AM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;**5**;MAR 25, 1999
;
; Variables GL, RD, FR, TO used by VA G&L routines.
;
N DFN,IFN,DGDT,NAME,FAC,WD,COM,PR,TS,AGE,HRCN,CA,N,UTL,ID,Z
A ; -- main
D L3 Q
;
L3 ; -- loop discharges
S DGDT=FR F S DGDT=$O(^DGPM("AMV3",DGDT)) Q:'DGDT!(DGDT>TO) D
. S DFN=0 F S DFN=$O(^DGPM("AMV3",DGDT,DFN)) Q:'DFN D
.. S IFN=0 F S IFN=$O(^DGPM("AMV3",DGDT,DFN,IFN)) Q:'IFN D 1,2,3
Q
;
1 S ID=9999999.9999999-DGDT
S N=$G(^DPT(+DFN,0)),NAME=$P(N,U),AGE=$$AGE
S N=$G(^DGPM(+IFN,0)),FAC=$P(N,U,5),CA=$P(N,U,14)
S N=$G(^DGPM(+$$MIP,0)),WD=$P(N,U,6)
S N=$G(^DGPM(+$$MTSP,0)),TS=$P(N,U,9),PR=$P(N,U,8)
S COM=$P($G(^AUPNPAT(DFN,11)),U,18),HRCN=$$HRCN^ADGF
S UTL=PR_U_AGE_U_WD_U_TS_U_COM_U_FAC
; -- death, newborn or other
I $D(^DPT(DFN,.35)),$P($P(^(.35),U),".")=RD D DEATH Q
I $D(^DIC(45.7,"B","NEWBORN",TS)) D NWBRN Q
D OTHER Q
;
2 ; -- ward
; -- newborn
I $D(^DIC(45.7,"B","NEWBORN",TS)) D Q
. I $$ONE S $P(DGWD("NB",WD),U,6)=$P(DGWD("NB",WD),U,6)+1
. S $P(DGWD("NB",WD),U,Z)=$P(DGWD("NB",WD),U,Z)+1
. S DGLWD("NB",WD)=DGLWD("NB",WD)+$$LOS2
; -- all other
I $$ONE S $P(DGWD(WD),U,6)=$P(DGWD(WD),U,6)+1
S $P(DGWD(WD),U,Z)=$P(DGWD(WD),U,Z)+1
S DGLWD(WD)=DGLWD(WD)+$$LOS2 Q
;
3 ; -- treating specialty
; -- peds
I +AGE<DGADULT D Q
. S $P(DGTSP(TS),U,Z)=$P(DGTSP(TS),U,Z)+1
. I $$ONE S $P(DGTSP(TS),U,6)=$P(DGTSP(TS),U,6)+1
. S DGLTSP(TS)=DGLTSP(TS)+$$LOS6
; -- adults
S $P(DGTSA(TS),U,Z)=$P(DGTSA(TS),U,Z)+1
I $$ONE S $P(DGTSA(TS),U,6)=$P(DGTSA(TS),U,6)+1
S DGLTSA(TS)=DGLTSA(TS)+$$LOS6 Q
;
DEATH ; -- deceased patients
S:GL ^TMP("DGZADS",$J,"DT",NAME,HRCN,IFN)=UTL
S DGT3D=DGT3D+1,Z=5 Q
;
NWBRN ; -- newborn patients
S:GL ^TMP("DGZADS",$J,"DN",NAME,HRCN,IFN)=UTL
S DGT3N=DGT3N+1,Z=2 Q
;
OTHER ; -- all other patients
S:GL ^TMP("DGZADS",$J,"AD",NAME,HRCN,IFN)=UTL
S DGT30=DGT30+1,Z=2 Q
;
MIP() ; -- movement, ifn, previous
Q $O(^($O(^DGPM("APMV",DFN,CA,ID)),0))
;
MTSP() ; -- movement, ts, previous
Q $O(^(+$O(^(+$O(^DGPM("ATS",DFN,CA,ID)),0)),0))
;
ONE() ; -- one day patients
Q $S($P(^DGPM($P(^DGPM(IFN,0),U,14),0),".")=RD:1,1:0)
;
AGE() ; -- age at admission
;N X,X1,X2 S X1=DGDT,X2=$P(N,U,3) D ^%DTC Q:'X "" Q X\365.25
N X,X1,X2 S X1=+$G(^DGPM(+$P(^DGPM(IFN,0),U,14),0)),X2=$P(N,U,3) D ^%DTC Q:'X "" Q X\365.25 ;IHS/ANMC/LJF/ENM 3/22/99
;
LOS2() ; -- ward los
N X,X1,X2 S X1=+^DGPM(+IFN,0),X2=+^DGPM(+$$MIP,0) D ^%DTC Q $S(X:X,1:1)
;
LOS6() ; -- t.s. los
N X,X1,X2 S X1=+^DGPM(+IFN,0),X2=+^DGPM(+$$MTSP,0) D ^%DTC Q $S(X:X,1:1)
ADGAD3 ; IHS/ADC/PDW/ENM - A&D DISCHARGES ; [ 05/19/2000 10:29 AM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;**5**;MAR 25, 1999
+2 ;
+3 ; Variables GL, RD, FR, TO used by VA G&L routines.
+4 ;
+5 NEW DFN,IFN,DGDT,NAME,FAC,WD,COM,PR,TS,AGE,HRCN,CA,N,UTL,ID,Z
A ; -- main
+1 DO L3
QUIT
+2 ;
L3 ; -- loop discharges
+1 SET DGDT=FR
FOR
SET DGDT=$ORDER(^DGPM("AMV3",DGDT))
IF 'DGDT!(DGDT>TO)
QUIT
Begin DoDot:1
+2 SET DFN=0
FOR
SET DFN=$ORDER(^DGPM("AMV3",DGDT,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+3 SET IFN=0
FOR
SET IFN=$ORDER(^DGPM("AMV3",DGDT,DFN,IFN))
IF 'IFN
QUIT
DO 1
DO 2
DO 3
End DoDot:2
End DoDot:1
+4 QUIT
+5 ;
1 SET ID=9999999.9999999-DGDT
+1 SET N=$GET(^DPT(+DFN,0))
SET NAME=$PIECE(N,U)
SET AGE=$$AGE
+2 SET N=$GET(^DGPM(+IFN,0))
SET FAC=$PIECE(N,U,5)
SET CA=$PIECE(N,U,14)
+3 SET N=$GET(^DGPM(+$$MIP,0))
SET WD=$PIECE(N,U,6)
+4 SET N=$GET(^DGPM(+$$MTSP,0))
SET TS=$PIECE(N,U,9)
SET PR=$PIECE(N,U,8)
+5 SET COM=$PIECE($GET(^AUPNPAT(DFN,11)),U,18)
SET HRCN=$$HRCN^ADGF
+6 SET UTL=PR_U_AGE_U_WD_U_TS_U_COM_U_FAC
+7 ; -- death, newborn or other
+8 IF $DATA(^DPT(DFN,.35))
IF $PIECE($PIECE(^(.35),U),".")=RD
DO DEATH
QUIT
+9 IF $DATA(^DIC(45.7,"B","NEWBORN",TS))
DO NWBRN
QUIT
+10 DO OTHER
QUIT
+11 ;
2 ; -- ward
+1 ; -- newborn
+2 IF $DATA(^DIC(45.7,"B","NEWBORN",TS))
Begin DoDot:1
+3 IF $$ONE
SET $PIECE(DGWD("NB",WD),U,6)=$PIECE(DGWD("NB",WD),U,6)+1
+4 SET $PIECE(DGWD("NB",WD),U,Z)=$PIECE(DGWD("NB",WD),U,Z)+1
+5 SET DGLWD("NB",WD)=DGLWD("NB",WD)+$$LOS2
End DoDot:1
QUIT
+6 ; -- all other
+7 IF $$ONE
SET $PIECE(DGWD(WD),U,6)=$PIECE(DGWD(WD),U,6)+1
+8 SET $PIECE(DGWD(WD),U,Z)=$PIECE(DGWD(WD),U,Z)+1
+9 SET DGLWD(WD)=DGLWD(WD)+$$LOS2
QUIT
+10 ;
3 ; -- treating specialty
+1 ; -- peds
+2 IF +AGE<DGADULT
Begin DoDot:1
+3 SET $PIECE(DGTSP(TS),U,Z)=$PIECE(DGTSP(TS),U,Z)+1
+4 IF $$ONE
SET $PIECE(DGTSP(TS),U,6)=$PIECE(DGTSP(TS),U,6)+1
+5 SET DGLTSP(TS)=DGLTSP(TS)+$$LOS6
End DoDot:1
QUIT
+6 ; -- adults
+7 SET $PIECE(DGTSA(TS),U,Z)=$PIECE(DGTSA(TS),U,Z)+1
+8 IF $$ONE
SET $PIECE(DGTSA(TS),U,6)=$PIECE(DGTSA(TS),U,6)+1
+9 SET DGLTSA(TS)=DGLTSA(TS)+$$LOS6
QUIT
+10 ;
DEATH ; -- deceased patients
+1 IF GL
SET ^TMP("DGZADS",$JOB,"DT",NAME,HRCN,IFN)=UTL
+2 SET DGT3D=DGT3D+1
SET Z=5
QUIT
+3 ;
NWBRN ; -- newborn patients
+1 IF GL
SET ^TMP("DGZADS",$JOB,"DN",NAME,HRCN,IFN)=UTL
+2 SET DGT3N=DGT3N+1
SET Z=2
QUIT
+3 ;
OTHER ; -- all other patients
+1 IF GL
SET ^TMP("DGZADS",$JOB,"AD",NAME,HRCN,IFN)=UTL
+2 SET DGT30=DGT30+1
SET Z=2
QUIT
+3 ;
MIP() ; -- movement, ifn, previous
+1 QUIT $ORDER(^($ORDER(^DGPM("APMV",DFN,CA,ID)),0))
+2 ;
MTSP() ; -- movement, ts, previous
+1 QUIT $ORDER(^(+$ORDER(^(+$ORDER(^DGPM("ATS",DFN,CA,ID)),0)),0))
+2 ;
ONE() ; -- one day patients
+1 QUIT $SELECT($PIECE(^DGPM($PIECE(^DGPM(IFN,0),U,14),0),".")=RD:1,1:0)
+2 ;
AGE() ; -- age at admission
+1 ;N X,X1,X2 S X1=DGDT,X2=$P(N,U,3) D ^%DTC Q:'X "" Q X\365.25
+2 ;IHS/ANMC/LJF/ENM 3/22/99
NEW X,X1,X2
SET X1=+$GET(^DGPM(+$PIECE(^DGPM(IFN,0),U,14),0))
SET X2=$PIECE(N,U,3)
DO ^%DTC
IF 'X
QUIT ""
QUIT X\365.25
+3 ;
LOS2() ; -- ward los
+1 NEW X,X1,X2
SET X1=+^DGPM(+IFN,0)
SET X2=+^DGPM(+$$MIP,0)
DO ^%DTC
QUIT $SELECT(X:X,1:1)
+2 ;
LOS6() ; -- t.s. los
+1 NEW X,X1,X2
SET X1=+^DGPM(+IFN,0)
SET X2=+^DGPM(+$$MTSP,0)
DO ^%DTC
QUIT $SELECT(X:X,1:1)
