ADGCEN30 ; IHS/ADC/PDW/ENM - CENSUS AID-PATIENT LIST ; [ 03/25/1999 11:48 AM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
;
N N,N0,N6,NAME,WARD,DGDT,DFN,IFN,TS,TY,TSNB
K ^TMP($J)
S TSNB=$S($O(^DIC(45.7,"B","NEWBORN",0)):$O(^(0)),1:"NEW")
A ; -- main
D LP1,LP3,LP2,LP6
G ^ADGCEN31 ;print report
Q
;
LP1 ; -- loop admissions
S DGDT=DGBDT-.0001
F S DGDT=$O(^DGPM("AMV1",DGDT)) Q:'DGDT!(DGDT>DGEDT) D
. S DFN=0 F S DFN=$O(^DGPM("AMV1",DGDT,DFN)) Q:'DFN D
.. S IFN=0 F S IFN=$O(^DGPM("AMV1",DGDT,DFN,IFN)) Q:'IFN D ADM
Q
;
ADM ; -- admission
S N=$G(^DGPM(IFN,0)),N0=$G(^DPT(DFN,0)),N6=$G(^DGPM(+$$TS,0))
S NAME=$P(N0,U),WARD=$P($G(^DIC(42,+$P(N,U,6),0)),U),TS=$P(N6,U,9)
; -- screen (selected ward? "A"=all wards)
I DGWD'="A",$P(N,U,6)'=DGWD Q
; -- newborn
I TS=TSNB D Q
. S ^TMP($J,"NEWA",WARD,DGDT,NAME,DFN)=""
; -- other
S ^TMP($J,"AA",WARD,DGDT,NAME,DFN)=""
Q
;
LP3 ; -- loop discharges
S DGDT=DGBDT-.0001
F S DGDT=$O(^DGPM("AMV3",DGDT)) Q:'DGDT!(DGDT>DGEDT) 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 DSC
Q
;
DSC ; -- discharge
S N=$G(^DGPM(IFN,0)),N0=$G(^DPT(DFN,0)),N6=$G(^DGPM(+$$TS,0))
S NAME=$P(N0,U),WARD=$P($G(^DIC(42,+$P($G(^DGPM(+$$MP,0)),U,6),0)),U)
S TY=$P(N,U,4),TS=$P(N6,U,9)
; -- screen (selected ward? "A"=all wards)
I DGWD'="A",$P($G(^DGPM(+$$MP,0)),U,6)'=DGWD Q
; -- newborn
I TS=TSNB D Q
. S ^TMP($J,"NEWD",WARD,DGDT,NAME,DFN)=""
; -- death
I $$DEATH D Q
. S ^TMP($J,"DT",WARD,DGDT,NAME,DFN)=""
; -- other
S ^TMP($J,"AD",WARD,DGDT,NAME,DFN)=""
Q
;
LP2 ; -- loop ward transfers
S DGDT=DGBDT-.0001
F S DGDT=$O(^DGPM("AMV2",DGDT)) Q:'DGDT!(DGDT>DGEDT) D
. S DFN=0 F S DFN=$O(^DGPM("AMV2",DGDT,DFN)) Q:'DFN D
.. S IFN=0 F S IFN=$O(^DGPM("AMV2",DGDT,DFN,IFN)) Q:'IFN D TRN
Q
;
TRN ; -- ward transfers
S N=$G(^DGPM(IFN,0)),N0=$G(^DPT(DFN,0)),N6=$G(^DGPM(+$$TS,0))
S NAME=$P(N0,U),WARD=$P($G(^DIC(42,+$P(N,U,6),0)),U),TS=$P(N6,U,9)
; -- screen (selected ward? "A"=all wards)
; -- xfr in
I DGWD="A"!($P(N,U,6)=DGWD) D Q:DGWD'="A"
. S ^TMP($J,"TI",WARD,DGDT,NAME,DFN)=""
; -- ward transfer, previous
S CA=$P(N,U,14),ID=9999999.9999999-N
S N6=$G(^DGPM(+$$TSP,0)),TS=$P(N6,U,9)
S NAME=$P($G(^DPT(DFN,0)),U)
S N=$G(^DGPM($$MP,0)),WARD=$P($G(^DIC(42,+$P(N,U,6),0)),U)
I DGWD'="A",$P(N,U,6)'=DGWD Q
; -- xfr out
S ^TMP($J,"TO",WARD,DGDT,NAME,DFN)=""
Q
;
LP6 ; -- loop treating specialty transfers
S DGDT=DGBDT-.0001
F S DGDT=$O(^DGPM("AMV6",DGDT)) Q:'DGDT!(DGDT>DGEDT) D
. S DFN=0 F S DFN=$O(^DGPM("AMV6",DGDT,DFN)) Q:'DFN D
.. S IFN=0 F S IFN=$O(^DGPM("AMV6",DGDT,DFN,IFN)) Q:'IFN D TSC
Q
;
TSC ; -- transfers from newborn service
S N=$G(^DGPM(IFN,0)),TS=$P(N,U,9)
I TS'=TSNB Q
Q:'$$M6A
S NAME=$P($G(^DPT(DFN,0)),U)
S WARD=$P($G(^DIC(42,+$P($G(^DGPM(+$P(N,U,24),0)),U,6),0)),U)
S ^TMP($J,"NEWT",WARD,DGDT,NAME,DFN)=""
; -- ward xfr too?
I +$P($G(^DGPM(+N,0)),U,24) S ^TMP($J,"TI",WARD,DGDT,NAME,DFN)=""
Q
;
MP() ; -- movement, previous
Q $O(^DGPM("APID",DFN,+$O(^DGPM("APID",DFN,9999999.9999999-DGDT)),0))
;
DEATH() ; -- type of discharge death
Q $S((+$G(^DG(405.1,+TY,"IHS"))>3)&(+$G(^DG(405.1,+TY,"IHS"))<8):1,1:0)
;
M6A() ; -- movement, ts, next
Q $O(^DGPM("APTT6",DFN,+$O(^DGPM("APTT6",DFN,DGDT)),0))
;
TS() ; -- t.s. ifn
Q:$O(^DGPM("APHY",+IFN,0)) $O(^DGPM("APHY",+IFN,0))
Q $O(^($O(^DGPM("ATS",DFN,+$P(N,U,14),9999999.9999999-N)),0))
;
TSP() ; -- t.s, previous
Q $O(^($O(^DGPM("ATS",DFN,CA,ID)),0))
ADGCEN30 ; IHS/ADC/PDW/ENM - CENSUS AID-PATIENT LIST ; [ 03/25/1999 11:48 AM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
+2 ;
+3 NEW N,N0,N6,NAME,WARD,DGDT,DFN,IFN,TS,TY,TSNB
+4 KILL ^TMP($JOB)
+5 SET TSNB=$SELECT($ORDER(^DIC(45.7,"B","NEWBORN",0)):$ORDER(^(0)),1:"NEW")
A ; -- main
+1 DO LP1
DO LP3
DO LP2
DO LP6
+2 ;print report
GOTO ^ADGCEN31
+3 QUIT
+4 ;
LP1 ; -- loop admissions
+1 SET DGDT=DGBDT-.0001
+2 FOR
SET DGDT=$ORDER(^DGPM("AMV1",DGDT))
IF 'DGDT!(DGDT>DGEDT)
QUIT
Begin DoDot:1
+3 SET DFN=0
FOR
SET DFN=$ORDER(^DGPM("AMV1",DGDT,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+4 SET IFN=0
FOR
SET IFN=$ORDER(^DGPM("AMV1",DGDT,DFN,IFN))
IF 'IFN
QUIT
DO ADM
End DoDot:2
End DoDot:1
+5 QUIT
+6 ;
ADM ; -- admission
+1 SET N=$GET(^DGPM(IFN,0))
SET N0=$GET(^DPT(DFN,0))
SET N6=$GET(^DGPM(+$$TS,0))
+2 SET NAME=$PIECE(N0,U)
SET WARD=$PIECE($GET(^DIC(42,+$PIECE(N,U,6),0)),U)
SET TS=$PIECE(N6,U,9)
+3 ; -- screen (selected ward? "A"=all wards)
+4 IF DGWD'="A"
IF $PIECE(N,U,6)'=DGWD
QUIT
+5 ; -- newborn
+6 IF TS=TSNB
Begin DoDot:1
+7 SET ^TMP($JOB,"NEWA",WARD,DGDT,NAME,DFN)=""
End DoDot:1
QUIT
+8 ; -- other
+9 SET ^TMP($JOB,"AA",WARD,DGDT,NAME,DFN)=""
+10 QUIT
+11 ;
LP3 ; -- loop discharges
+1 SET DGDT=DGBDT-.0001
+2 FOR
SET DGDT=$ORDER(^DGPM("AMV3",DGDT))
IF 'DGDT!(DGDT>DGEDT)
QUIT
Begin DoDot:1
+3 SET DFN=0
FOR
SET DFN=$ORDER(^DGPM("AMV3",DGDT,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+4 SET IFN=0
FOR
SET IFN=$ORDER(^DGPM("AMV3",DGDT,DFN,IFN))
IF 'IFN
QUIT
DO DSC
End DoDot:2
End DoDot:1
+5 QUIT
+6 ;
DSC ; -- discharge
+1 SET N=$GET(^DGPM(IFN,0))
SET N0=$GET(^DPT(DFN,0))
SET N6=$GET(^DGPM(+$$TS,0))
+2 SET NAME=$PIECE(N0,U)
SET WARD=$PIECE($GET(^DIC(42,+$PIECE($GET(^DGPM(+$$MP,0)),U,6),0)),U)
+3 SET TY=$PIECE(N,U,4)
SET TS=$PIECE(N6,U,9)
+4 ; -- screen (selected ward? "A"=all wards)
+5 IF DGWD'="A"
IF $PIECE($GET(^DGPM(+$$MP,0)),U,6)'=DGWD
QUIT
+6 ; -- newborn
+7 IF TS=TSNB
Begin DoDot:1
+8 SET ^TMP($JOB,"NEWD",WARD,DGDT,NAME,DFN)=""
End DoDot:1
QUIT
+9 ; -- death
+10 IF $$DEATH
Begin DoDot:1
+11 SET ^TMP($JOB,"DT",WARD,DGDT,NAME,DFN)=""
End DoDot:1
QUIT
+12 ; -- other
+13 SET ^TMP($JOB,"AD",WARD,DGDT,NAME,DFN)=""
+14 QUIT
+15 ;
LP2 ; -- loop ward transfers
+1 SET DGDT=DGBDT-.0001
+2 FOR
SET DGDT=$ORDER(^DGPM("AMV2",DGDT))
IF 'DGDT!(DGDT>DGEDT)
QUIT
Begin DoDot:1
+3 SET DFN=0
FOR
SET DFN=$ORDER(^DGPM("AMV2",DGDT,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+4 SET IFN=0
FOR
SET IFN=$ORDER(^DGPM("AMV2",DGDT,DFN,IFN))
IF 'IFN
QUIT
DO TRN
End DoDot:2
End DoDot:1
+5 QUIT
+6 ;
TRN ; -- ward transfers
+1 SET N=$GET(^DGPM(IFN,0))
SET N0=$GET(^DPT(DFN,0))
SET N6=$GET(^DGPM(+$$TS,0))
+2 SET NAME=$PIECE(N0,U)
SET WARD=$PIECE($GET(^DIC(42,+$PIECE(N,U,6),0)),U)
SET TS=$PIECE(N6,U,9)
+3 ; -- screen (selected ward? "A"=all wards)
+4 ; -- xfr in
+5 IF DGWD="A"!($PIECE(N,U,6)=DGWD)
Begin DoDot:1
+6 SET ^TMP($JOB,"TI",WARD,DGDT,NAME,DFN)=""
End DoDot:1
IF DGWD'="A"
QUIT
+7 ; -- ward transfer, previous
+8 SET CA=$PIECE(N,U,14)
SET ID=9999999.9999999-N
+9 SET N6=$GET(^DGPM(+$$TSP,0))
SET TS=$PIECE(N6,U,9)
+10 SET NAME=$PIECE($GET(^DPT(DFN,0)),U)
+11 SET N=$GET(^DGPM($$MP,0))
SET WARD=$PIECE($GET(^DIC(42,+$PIECE(N,U,6),0)),U)
+12 IF DGWD'="A"
IF $PIECE(N,U,6)'=DGWD
QUIT
+13 ; -- xfr out
+14 SET ^TMP($JOB,"TO",WARD,DGDT,NAME,DFN)=""
+15 QUIT
+16 ;
LP6 ; -- loop treating specialty transfers
+1 SET DGDT=DGBDT-.0001
+2 FOR
SET DGDT=$ORDER(^DGPM("AMV6",DGDT))
IF 'DGDT!(DGDT>DGEDT)
QUIT
Begin DoDot:1
+3 SET DFN=0
FOR
SET DFN=$ORDER(^DGPM("AMV6",DGDT,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+4 SET IFN=0
FOR
SET IFN=$ORDER(^DGPM("AMV6",DGDT,DFN,IFN))
IF 'IFN
QUIT
DO TSC
End DoDot:2
End DoDot:1
+5 QUIT
+6 ;
TSC ; -- transfers from newborn service
+1 SET N=$GET(^DGPM(IFN,0))
SET TS=$PIECE(N,U,9)
+2 IF TS'=TSNB
QUIT
+3 IF '$$M6A
QUIT
+4 SET NAME=$PIECE($GET(^DPT(DFN,0)),U)
+5 SET WARD=$PIECE($GET(^DIC(42,+$PIECE($GET(^DGPM(+$PIECE(N,U,24),0)),U,6),0)),U)
+6 SET ^TMP($JOB,"NEWT",WARD,DGDT,NAME,DFN)=""
+7 ; -- ward xfr too?
+8 IF +$PIECE($GET(^DGPM(+N,0)),U,24)
SET ^TMP($JOB,"TI",WARD,DGDT,NAME,DFN)=""
+9 QUIT
+10 ;
MP() ; -- movement, previous
+1 QUIT $ORDER(^DGPM("APID",DFN,+$ORDER(^DGPM("APID",DFN,9999999.9999999-DGDT)),0))
+2 ;
DEATH() ; -- type of discharge death
+1 QUIT $SELECT((+$GET(^DG(405.1,+TY,"IHS"))>3)&(+$GET(^DG(405.1,+TY,"IHS"))<8):1,1:0)
+2 ;
M6A() ; -- movement, ts, next
+1 QUIT $ORDER(^DGPM("APTT6",DFN,+$ORDER(^DGPM("APTT6",DFN,DGDT)),0))
+2 ;
TS() ; -- t.s. ifn
+1 IF $ORDER(^DGPM("APHY",+IFN,0))
QUIT $ORDER(^DGPM("APHY",+IFN,0))
+2 QUIT $ORDER(^($ORDER(^DGPM("ATS",DFN,+$PIECE(N,U,14),9999999.9999999-N)),0))
+3 ;
TSP() ; -- t.s, previous
+1 QUIT $ORDER(^($ORDER(^DGPM("ATS",DFN,CA,ID)),0))
