ADGEVNT ; IHS/ADC/PDW/ENM - IHS/ADT EVENT DRIVER ; [ 03/25/1999 11:48 AM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
;
A ; -- driver
N DGPMCA S DGPMCA=$S(+$P(DGPMA,U,14):$P(DGPMA,U,14),1:+$P(DGPMP,U,14))
D @DGPMT Q
;
1 ; -- admissions
I DGPMA]"" D NBCHK ;check if nb admit date matches dob
I DGPMP="" D APCDALV^ADGCALLS,BULL,AS Q ;new
I DGPMA="" D APCDVDLT^ADGCALLS Q ;deleted
I +DGPMP'=+DGPMA D APCDCVDT^ADGCALLS ;date/time
I +$P(DGPMA,U,17) D A3 ;discharged
D BULL,AS Q
;
3 ; -- discharges
I +$G(^DPT(DFN,.35)) N X,Y S X="NOW" D ^%DT S ^AGPATCH(Y,DUZ(2),DFN)=""
I DGPMP="" D APCDALVR^ADGCALLS,BULL,IC Q ;new
I DGPMA="" S DIK="^AUPNVINP(",DA=$$VH D:DA ^DIK K DIK,DA Q ;deleted
I +DGPMA'=+DGPMP S APCDALVR("APCDDSCH")=+DGPMA
I $P(DGPMA,U,4)'=$P(DGPMP,U,4) S APCDALVR("APCDTDT")=$P(DGPMA,U,4)
I $P(DGPMA,U,5)'=$P(DGPMP,U,5) D
. S:$P($$TF,"`",2) APCDALVR("APCDTTT")=$$TF
I $D(APCDALVR) D APCDALVR^ADGCALLS
D BULL
Q
;
2 ; -- transfers
D BULL Q
;
6 ; -- specialty
Q:'$P(^DGPM(DGPMCA,0),U,17)
I DGPMA]"" D NBCHK ;check if nb admit date matches dob
I $P(^AUPNVINP($$VH,0),U,5)'=$$DSRV^ADGCALLS D
. S APCDALVR("APCDTDCS")="`"_$$DSRV^ADGCALLS D APCDALVR^ADGCALLS
Q
;
4 ; -- check-in lodger
5 ; -- check-out lodger
Q
;
A3 ; -- admission movement with discharge pointer
I '$$VH N DGPMA,DGPMP S DGPMA=$$N3,DGPMP="" D APCDALVR^ADGCALLS Q
S:$P(DGPMA,U,4)'=$P(DGPMP,U,4) APCDALVR("APCDTAT")="`"_$P(DGPMA,U,4)
I $$A6 D
. S APCDALVR("APCDTADS")="`"_$P(^TMP("DGPM",$J,6,$$TS,"A"),U,9)
. S APCDALVR("APCDTDCS")="`"_$$DSRV^ADGCALLS
Q:'$D(APCDALVR)
N DGPMA,DGPMP S DGPMA=$$N3,DGPMP=DGPMA D APCDALVR^ADGCALLS
Q
;
IC ; -- incomplete chart
Q:'$P($G(^DG(43,1,9999999.02)),U,4) ;ic on dsch okay?
I '$D(^ADGIC(DFN,0))#2 D
. L +^ADGIC(0):3 I '$T Q
. S X="`"_DFN,DIC="^ADGIC(",DLAYGO=9009013,DIC(0)="L"
. D ^DIC L -^ADGIC(0)
I '$D(^ADGIC(DFN,0))#2 Q
S:'$D(^ADGIC(DFN,"D",0)) ^ADGIC(DFN,"D",0)="^9009013.01D^^"
S X=+DGPMA,DA(1)=DFN,DA=$P(^ADGIC(DFN,"D",0),U,3)+1
S DIC="^ADGIC("_DFN_",""D"",",DLAYGO=9009013,DIC(0)="L"
L +^ADGIC(DFN,"D"):3 I '$T Q
D ^DIC
N C,N,T,I S C=$P(DGPMA,U,14),N=$G(^DGPM(+C,0)),I=9999999.9999999-DGPMA
S T=+$O(^(+$O(^DGPM("ATS",DFN,+C,I)),0))
S DR="1///^S X=+N;2///^S X=$P(N,U,6);3///^S X=""`""_T",DIE=DIC
D ^DIE L -^ADGIC(DFN,"D") K DIC,DIE,DR Q
;
AS ; -- a sheet and locator
D EN^ADGCRB0(DFN,DGPMDA)
D EN^ADGLOC0(DFN,DGPMDA) Q
;
VI() ; -- visit ien
Q +$O(^AUPNVSIT("AA",DFN,+$$ID,0))
;
VH() ; -- v hospitalization ien
Q +$O(^AUPNVINP("AD",+$$VI,0))
;
ID() ; -- inverse date
Q (9999999-$P(+^DGPM(DGPMCA,0),"."))_"."_$P(+^DGPM(DGPMCA,0),".",2)
;
N3() ; -- discharge node
Q $G(^DGPM(+$P(^DGPM(+DGPMCA,0),U,17),0))
;
TF() ; -- transfer facility
N X S X=$P(DGPMA,U,5) Q $S(X["DIC(4":"VA/IHS.`",1:"VENDOR.`")_+X
;
TS() ; -- specialty ien
Q $O(^DGPM("APHY",+DGPMDA,0))
;
A6() ; -- admitting service changed (1=yes,0=no)
Q $S($P($G(^TMP("DGPM",$J,6,+$$TS,"A")),U,9)'=$P($G(^("P")),U,9):1,1:0)
;
NBCHK ; -- checks newborn admit date against date of birth
NEW X,DOB
S X=$O(^DIC(45.7,"CIHS","07",0)) I X="" Q ;no nb code
S Y=$S(DGPMT=1:$$TS,1:DGPMDA) Q:Y=""
Q:$P($G(^DGPM(+Y,0)),U,9)'=X ;not newborn
S DOB=$P($G(^DPT(+$P(DGPMA,U,3),0)),U,3) Q:DOB=""
I DOB'=(+DGPMA\1) D
. W !!,*7,"NEWBORN ADMIT DATE DOES NOT MATCH DATE OF BIRTH"
. W !,"PLEASE FIX INCORRECT DATE!"
Q
;
BULL ; -- check if bulletins turned on and call subrtns to send them
I DGPMT=1 D Q
. ; -- check if transfer in
. I $$ON(9999999.12) D
.. NEW ADTYP S ADTYP=$$VAL^XBDIQ1(405.1,$P(DGPMA,U,4),9999999.1)
.. I (ADTYP=2)!(ADTYP=3) D TI^ADGBULL1
. ;
. ; -- check if readmission
. I $$ON(9999999.15) D K DGRE
.. NEW DGDT S DGDT=+DGPMA D ^ADGREADM Q:'$D(DGRE)
.. I DGRE["A" D READM^ADGBULL1
.. I DGRE["D" D ADMDS^ADGBULL1
;
I DGPMT=2 D Q
. ; -- check if icu transfer
. I $$ON(9999999.11) D
.. I $$VAL^XBDIQ1(42,+$P(DGPMA,U,6),9999999.01)="YES" D ICU^ADGBULL1
;
I DGPMT=3 D Q
. NEW X S X=$$VAL^XBDIQ1(405.1,+$P(DGPMA,U,4),9999999.1) Q:X=""
. I (X<2)!(X>7) Q
. I X=2,$$ON(9999999.13) D TO^ADGBULL1 Q
. I X=3,$$ON(9999999.17) D AMA^ADGBULL1 Q
. I $$ON(9999999.14) D DEATH^ADGBULL1
Q
;
ON(N) ; -- returns 1 if bulletin turned on
Q $$VALI^XBDIQ1(43,1,N)
ADGEVNT ; IHS/ADC/PDW/ENM - IHS/ADT EVENT DRIVER ; [ 03/25/1999 11:48 AM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
+2 ;
A ; -- driver
+1 NEW DGPMCA
SET DGPMCA=$SELECT(+$PIECE(DGPMA,U,14):$PIECE(DGPMA,U,14),1:+$PIECE(DGPMP,U,14))
+2 DO @DGPMT
QUIT
+3 ;
1 ; -- admissions
+1 ;check if nb admit date matches dob
IF DGPMA]""
DO NBCHK
+2 ;new
IF DGPMP=""
DO APCDALV^ADGCALLS
DO BULL
DO AS
QUIT
+3 ;deleted
IF DGPMA=""
DO APCDVDLT^ADGCALLS
QUIT
+4 ;date/time
IF +DGPMP'=+DGPMA
DO APCDCVDT^ADGCALLS
+5 ;discharged
IF +$PIECE(DGPMA,U,17)
DO A3
+6 DO BULL
DO AS
QUIT
+7 ;
3 ; -- discharges
+1 IF +$GET(^DPT(DFN,.35))
NEW X,Y
SET X="NOW"
DO ^%DT
SET ^AGPATCH(Y,DUZ(2),DFN)=""
+2 ;new
IF DGPMP=""
DO APCDALVR^ADGCALLS
DO BULL
DO IC
QUIT
+3 ;deleted
IF DGPMA=""
SET DIK="^AUPNVINP("
SET DA=$$VH
IF DA
DO ^DIK
KILL DIK,DA
QUIT
+4 IF +DGPMA'=+DGPMP
SET APCDALVR("APCDDSCH")=+DGPMA
+5 IF $PIECE(DGPMA,U,4)'=$PIECE(DGPMP,U,4)
SET APCDALVR("APCDTDT")=$PIECE(DGPMA,U,4)
+6 IF $PIECE(DGPMA,U,5)'=$PIECE(DGPMP,U,5)
Begin DoDot:1
+7 IF $PIECE($$TF,"`",2)
SET APCDALVR("APCDTTT")=$$TF
End DoDot:1
+8 IF $DATA(APCDALVR)
DO APCDALVR^ADGCALLS
+9 DO BULL
+10 QUIT
+11 ;
2 ; -- transfers
+1 DO BULL
QUIT
+2 ;
6 ; -- specialty
+1 IF '$PIECE(^DGPM(DGPMCA,0),U,17)
QUIT
+2 ;check if nb admit date matches dob
IF DGPMA]""
DO NBCHK
+3 IF $PIECE(^AUPNVINP($$VH,0),U,5)'=$$DSRV^ADGCALLS
Begin DoDot:1
+4 SET APCDALVR("APCDTDCS")="`"_$$DSRV^ADGCALLS
DO APCDALVR^ADGCALLS
End DoDot:1
+5 QUIT
+6 ;
4 ; -- check-in lodger
5 ; -- check-out lodger
+1 QUIT
+2 ;
A3 ; -- admission movement with discharge pointer
+1 IF '$$VH
NEW DGPMA,DGPMP
SET DGPMA=$$N3
SET DGPMP=""
DO APCDALVR^ADGCALLS
QUIT
+2 IF $PIECE(DGPMA,U,4)'=$PIECE(DGPMP,U,4)
SET APCDALVR("APCDTAT")="`"_$PIECE(DGPMA,U,4)
+3 IF $$A6
Begin DoDot:1
+4 SET APCDALVR("APCDTADS")="`"_$PIECE(^TMP("DGPM",$JOB,6,$$TS,"A"),U,9)
+5 SET APCDALVR("APCDTDCS")="`"_$$DSRV^ADGCALLS
End DoDot:1
+6 IF '$DATA(APCDALVR)
QUIT
+7 NEW DGPMA,DGPMP
SET DGPMA=$$N3
SET DGPMP=DGPMA
DO APCDALVR^ADGCALLS
+8 QUIT
+9 ;
IC ; -- incomplete chart
+1 ;ic on dsch okay?
IF '$PIECE($GET(^DG(43,1,9999999.02)),U,4)
QUIT
+2 IF '$DATA(^ADGIC(DFN,0))#2
Begin DoDot:1
+3 LOCK +^ADGIC(0):3
IF '$TEST
QUIT
+4 SET X="`"_DFN
SET DIC="^ADGIC("
SET DLAYGO=9009013
SET DIC(0)="L"
+5 DO ^DIC
LOCK -^ADGIC(0)
End DoDot:1
+6 IF '$DATA(^ADGIC(DFN,0))#2
QUIT
+7 IF '$DATA(^ADGIC(DFN,"D",0))
SET ^ADGIC(DFN,"D",0)="^9009013.01D^^"
+8 SET X=+DGPMA
SET DA(1)=DFN
SET DA=$PIECE(^ADGIC(DFN,"D",0),U,3)+1
+9 SET DIC="^ADGIC("_DFN_",""D"","
SET DLAYGO=9009013
SET DIC(0)="L"
+10 LOCK +^ADGIC(DFN,"D"):3
IF '$TEST
QUIT
+11 DO ^DIC
+12 NEW C,N,T,I
SET C=$PIECE(DGPMA,U,14)
SET N=$GET(^DGPM(+C,0))
SET I=9999999.9999999-DGPMA
+13 SET T=+$ORDER(^(+$ORDER(^DGPM("ATS",DFN,+C,I)),0))
+14 SET DR="1///^S X=+N;2///^S X=$P(N,U,6);3///^S X=""`""_T"
SET DIE=DIC
+15 DO ^DIE
LOCK -^ADGIC(DFN,"D")
KILL DIC,DIE,DR
QUIT
+16 ;
AS ; -- a sheet and locator
+1 DO EN^ADGCRB0(DFN,DGPMDA)
+2 DO EN^ADGLOC0(DFN,DGPMDA)
QUIT
+3 ;
VI() ; -- visit ien
+1 QUIT +$ORDER(^AUPNVSIT("AA",DFN,+$$ID,0))
+2 ;
VH() ; -- v hospitalization ien
+1 QUIT +$ORDER(^AUPNVINP("AD",+$$VI,0))
+2 ;
ID() ; -- inverse date
+1 QUIT (9999999-$PIECE(+^DGPM(DGPMCA,0),"."))_"."_$PIECE(+^DGPM(DGPMCA,0),".",2)
+2 ;
N3() ; -- discharge node
+1 QUIT $GET(^DGPM(+$PIECE(^DGPM(+DGPMCA,0),U,17),0))
+2 ;
TF() ; -- transfer facility
+1 NEW X
SET X=$PIECE(DGPMA,U,5)
QUIT $SELECT(X["DIC(4":"VA/IHS.`",1:"VENDOR.`")_+X
+2 ;
TS() ; -- specialty ien
+1 QUIT $ORDER(^DGPM("APHY",+DGPMDA,0))
+2 ;
A6() ; -- admitting service changed (1=yes,0=no)
+1 QUIT $SELECT($PIECE($GET(^TMP("DGPM",$JOB,6,+$$TS,"A")),U,9)'=$PIECE($GET(^("P")),U,9):1,1:0)
+2 ;
NBCHK ; -- checks newborn admit date against date of birth
+1 NEW X,DOB
+2 ;no nb code
SET X=$ORDER(^DIC(45.7,"CIHS","07",0))
IF X=""
QUIT
+3 SET Y=$SELECT(DGPMT=1:$$TS,1:DGPMDA)
IF Y=""
QUIT
+4 ;not newborn
IF $PIECE($GET(^DGPM(+Y,0)),U,9)'=X
QUIT
+5 SET DOB=$PIECE($GET(^DPT(+$PIECE(DGPMA,U,3),0)),U,3)
IF DOB=""
QUIT
+6 IF DOB'=(+DGPMA\1)
Begin DoDot:1
+7 WRITE !!,*7,"NEWBORN ADMIT DATE DOES NOT MATCH DATE OF BIRTH"
+8 WRITE !,"PLEASE FIX INCORRECT DATE!"
End DoDot:1
+9 QUIT
+10 ;
BULL ; -- check if bulletins turned on and call subrtns to send them
+1 IF DGPMT=1
Begin DoDot:1
+2 ; -- check if transfer in
+3 IF $$ON(9999999.12)
Begin DoDot:2
+4 NEW ADTYP
SET ADTYP=$$VAL^XBDIQ1(405.1,$PIECE(DGPMA,U,4),9999999.1)
+5 IF (ADTYP=2)!(ADTYP=3)
DO TI^ADGBULL1
End DoDot:2
+6 ;
+7 ; -- check if readmission
+8 IF $$ON(9999999.15)
Begin DoDot:2
+9 NEW DGDT
SET DGDT=+DGPMA
DO ^ADGREADM
IF '$DATA(DGRE)
QUIT
+10 IF DGRE["A"
DO READM^ADGBULL1
+11 IF DGRE["D"
DO ADMDS^ADGBULL1
End DoDot:2
KILL DGRE
End DoDot:1
QUIT
+12 ;
+13 IF DGPMT=2
Begin DoDot:1
+14 ; -- check if icu transfer
+15 IF $$ON(9999999.11)
Begin DoDot:2
+16 IF $$VAL^XBDIQ1(42,+$PIECE(DGPMA,U,6),9999999.01)="YES"
DO ICU^ADGBULL1
End DoDot:2
End DoDot:1
QUIT
+17 ;
+18 IF DGPMT=3
Begin DoDot:1
+19 NEW X
SET X=$$VAL^XBDIQ1(405.1,+$PIECE(DGPMA,U,4),9999999.1)
IF X=""
QUIT
+20 IF (X<2)!(X>7)
QUIT
+21 IF X=2
IF $$ON(9999999.13)
DO TO^ADGBULL1
QUIT
+22 IF X=3
IF $$ON(9999999.17)
DO AMA^ADGBULL1
QUIT
+23 IF $$ON(9999999.14)
DO DEATH^ADGBULL1
End DoDot:1
QUIT
+24 QUIT
+25 ;
ON(N) ; -- returns 1 if bulletin turned on
+1 QUIT $$VALI^XBDIQ1(43,1,N)
