BDGBULL1 ; IHS/ANMC/LJF - POST ADT BULLETINS ;
;;5.3;PIMS;**1007,1013**;FEB 27, 2007
; Called by ADT Event Driver protocol
;
; Input Variables:
; DGPMT = type of event (1-admit, 3-discharge, etc.)
; DGPMDA = event ien
; DGPMCA = admission ien
; DGPMP = zero node of 405 entry Prior to event
; DGPMA = zero node of 405 entry After event
; DFN = patient ien
; DGQUIET = if $G(DGQUIET), no user interaction
;
;
;cmi/anch/maw 2/22/2007 added code OBS and code in EVENT to send bulletin if a patient goes from observation to admission PATCH 1007 item 1007.43
;ihs/cmi/maw 04/08/2011 PATCH 1013 RQMT157 added code for delete admit reason
;
EVENT ; process event type
NEW DIV S DIV=$$DIV^BDGPAR(DUZ(2)) Q:'DIV
;
; admission event
I DGPMT=1 D Q
. ; check if transfer in from another facility
. I $$GET1^DIQ(9009020.1,DIV,101)="YES" D
.. NEW CODE S CODE=$$GET1^DIQ(405.1,+$P(DGPMA,U,4),9999999.1)
.. I (CODE=2)!(CODE=3) D TI
. ;
. ;IHS/ITSC/LJF 4/9/2004 moved code around so if admit w/in 24 hours then quit after
. ; check if readmitted w/24 hrs to same service (might be same admit)
. NEW BDGQUIT
. I $$GET1^DIQ(9009020.1,DIV,114)="YES" D Q:$G(BDGQUIT)
.. S Y=$$READM24(DGPMCA,DFN) I Y S BDGQUIT=1 D SAMEADM($P(Y,U,2))
. ;
. ; check if readmission within parameter limit
. I $$GET1^DIQ(9009020.1,DIV,104)="YES" D
.. S Y=$$READM^BDGF1(DGPMCA,DFN) I Y D READM($P(Y,U,2))
. ;
. ; check if readmitted w/24 hrs to same service (might be same admit)
. ;I $$GET1^DIQ(9009020.1,DIV,114)="YES" D
. ;. S Y=$$READM24(DGPMCA,DFN) I Y D SAMEADM($P(Y,U,2))
. ;IHS/ITSC/LJF 4/9/2004 end of changes
. ;
. ; check if admit after day surgery within parameter limit
. I $$GET1^DIQ(9009020.1,DIV,106)="YES" D
.. S Y=$$DSADM^BDGF1(DGPMCA,DFN) I Y D ADMDS($P(Y,U,2))
. ;
. ;cmi/anch/maw 2/22/2007 added bulleting if observation to admission PATCH 1007 item 1007.43
. ;check if observation to admission
. I $$GET1^DIQ(9009020.1,DIV,115)="YES" D
.. I $$LASTSRVN^BDGF1(DGPMCA,DFN)["OBSERVATION" D OBS
. ;
. ; check if admission was deleted
. I DGPMA="" D DELADM
;
; ward transfer event
;IHS/ITSC/LJF 4/9/2004 moved code around so if return to icu, only send one bulletin
I DGPMT=2 D Q
. ; check if receiving ward is an ICU
. I $$GET1^DIQ(9009016.5,+$P(DGPMA,U,6),101)="YES" D
.. NEW BDGQUIT
.. ;
.. ; is this a return to ICU within parameter limit?
.. I $$GET1^DIQ(9009020.1,DIV,111)="YES" D Q:$G(BDGQUIT) ;if bulletin turned on
... S X=$$LASTICU(DGPMCA,+DGPMA) Q:'X ;date disch from ICU
... I $$FMDIFF^XLFDT(+DGPMA,X)'>$$GET1^DIQ(9009020.1,DIV,112) S BDGQUIT=1 D RICU(X) Q
.. ;
.. I $$GET1^DIQ(9009020.1,DIV,110)="YES" D ICU
.. ;
.. ; is this also a return to ICU within parameter limit?
.. ;Q:$$GET1^DIQ(9009020.1,DIV,111)'="YES" ;bulletin not turned on
.. ;S X=$$LASTICU(DGPMCA,+DGPMA) Q:'X ;date disch from ICU
.. ;I $$FMDIFF^XLFDT(+DGPMA,X)'>$$GET1^DIQ(9009020.1,DIV,112) D RICU(X)
;IHS/ITSC/LJF 4/9/2004 end of changes
;
; discharge event
I DGPMT=3 D Q
. Q:DGPMA="" ;quit if discharge deleted
. ;
. ; check if patient died
. I $$GET1^DIQ(2,DFN,.351)]"" D Q
.. I $$GET1^DIQ(9009020.1,DIV,103)="YES" D DEATH
. ;
. ; check if AMA discharge
. I $$GET1^DIQ(405.1,$$GET1^DIQ(405,+DGPMDA,.04,"I"),9999999.1)=3 D
.. I $$GET1^DIQ(9009020.1,DIV,108)="YES" D AMA
. ;
. ; check if transfer to other facility
. I $$GET1^DIQ(9009020.1,DIV,102)="YES" D
.. I $$GET1^DIQ(405,+DGPMDA,.05)]"" D TO
. ;
. ; check if LOS less than 24 hours and not observation
. I $$LOSHRS^BDGF1(DGPMCA,+DGPMA,DFN)<24 D
.. I $$LASTSRVN^BDGF1(DGPMCA,DFN)'["OBSERVATION" D
... I $$GET1^DIQ(9009020.1,DIV,113)="YES" D ONEDAY
. ;
;
Q
GEN ; -- set general data
K XMB ;IHS/ITSC/LJF 4/9/2004 start with clean array
S XMB(1)=$$GET1^DIQ(2,DFN,.01) ;patient name
S XMB(2)=$$HRCN^BDGF2(DFN,DUZ(2)) ;chart #
S XMB(3)=$$GET1^DIQ(405,DGPMCA,.01) ;admit date/time
S X="NOW",%DT="T" D ^%DT S XMDT=Y ;send bulletin now
Q
;
TI ; -- bulletin for transfers in to facility
D GEN ;set general variables
S XMB="BDG TRANSFER IN ADMIT" ;bulletin name
S XMB(4)=$$GET1^DIQ(405,+DGPMCA,.05) ;transfer facility
S XMB(5)=$$GET1^DIQ(405,+DGPMCA,.1) ;admitting dx
S XMB(6)=$$ADMSRV^BDGF1(DGPMCA,DFN) ;service
D ^XMB Q
;
OBS ; -- bulletin for observation to admission
;cmi/anch/maw 2/22/2007 added for observation to admission PATCH 1007 item 1007.43
D GEN ;set general variables
S XMB="BDG OBS TO ADMIT" ;bulletin name
S XMB(4)=$$ADMSRV^BDGF1(DGPMCA,DFN) ;service
S XMB(5)=$$GET1^DIQ(405,+DGPMCA,.1) ;admitting dx
D ^XMB Q
;
READM(LAST) ; -- bulletin for readmissions
; LAST=last discharge date in FM format
D GEN ;set gen vars
S XMB="BDG READMISSION" ;bulletin name
S XMB(4)=$$GET1^DIQ(9009020.1,+$$DIV^BDGPAR(DUZ(2)),105) ;time limit
S XMB(5)=$$GET1^DIQ(405,+DGPMCA,.1) ;admitting dx
S XMB(6)=$$FMTE^XLFDT(LAST) ;last discharge
S XMB(7)=$$LASTDX(LAST) ;last adm dx
S XMB(8)=$$ADMSRV^BDGF1(DGPMCA,DFN) ;new service
S XMB(9)=$$LASTSRV(LAST) ;last service
D ^XMB Q
;
SAMEADM(LAST) ; -- bulletin for readmission within 24 hrs to same service
; LAST=last discharge date in FM format
D GEN ;set gen vars
S XMB="BDG SAME ADMIT" ;bulletin name
S XMB(4)=$$GET1^DIQ(405,+DGPMCA,.1) ;admitting dx
S XMB(5)=$$LASTDX(LAST) ;last adm dx
S XMB(6)=$$FMTE^XLFDT(LAST) ;last discharge
S XMB(7)=$$ADMSRV^BDGF1(DGPMCA,DFN) ;new service
D ^XMB Q
;
ADMDS(LAST) ; -- bulletin for admit after day surgery
; LAST=date of last day surgery
D GEN ;set gen variables
S XMB="BDG ADMIT AFTER DAY SURG" ;bulletin name
S XMB(4)=$$GET1^DIQ(9009020.1,+$$DIV^BDGPAR(DUZ(2)),107) ;time limit
S XMB(5)=$$GET1^DIQ(405,+DGPMCA,.1) ;adm dx
S XMB(6)=$$FMTE^XLFDT(LAST) ;day surgery date/time
S XMB(9)=$$ADMSRV^BDGF1(+DGPMCA,DFN) ;adm srv
;S Y=DGDS D DD^%DT S XMB(6)=Y ;day surg date/time;IHS/ITSC/LJF 4/9/2004
S XMB(7)=$$DSPROC^BDGDSA(LAST,DFN) ;day surg procedure
S Y=$$DSDISP^BDGDSA(LAST,DFN) ;ds disposition
;S XMB(8)=$S(DGDIS="ADM":"**ADMITTED DIRECTLY FROM DAY SURGERY**",1:"")
S XMB(8)=$S(Y="ADM":"**ADMITTED DIRECTLY FROM DAY SURGERY**",1:"") ;IHS/ITSC/LJF 4/9/2004
D ^XMB Q
;
DELADM ; bulletin for deleted admission
D GEN ;set gen variables
S XMB="BDG DELETED ADMITS" ;bulletin name
S XMB(3)=$$FMTE^XLFDT(+DGPMP) ;deleted admit date
S XMB(4)=$$GET1^DIQ(42,+$P(DGPMP,U,6),.01) ;ward
S XMB(5)=$$GET1^DIQ(200,DUZ,.01) ;deleted by
S XMB(6)=$$HTE^XLFDT($H) ;deleted at
S XMB(7)=$G(BDGDLREA) ;delete reason ihs/cmi/maw 04/08/2011 Patch 1013 RQMT157
K BDGDLREA
D ^XMB Q
;
ICU ; -- bulletin for ICU transfers
K XMB
S XMB="BDG ICU TRANSFER" ;bulletin name
S XMB(1)=$$GET1^DIQ(2,DFN,.01) ;patient name
S XMB(2)=$$HRCN^BDGF2(DFN,DUZ(2)) ;chart number
S XMB(3)=$$GET1^DIQ(405,+DGPMDA,.01) ;transfer date/time
S XMB(4)=$$GET1^DIQ(405,+DGPMCA,.1) ;admitting dx
; treating specialty
S XMB(5)=$$GET1^DIQ(405,+$$PRIORTXN^BDGF1(+DGPMA,DGPMCA,DFN),.09)
S X="NOW",%DT="T" D ^%DT S XMDT=Y ;send bulletin now
D ^XMB Q
;
RICU(DATE) ; -- bulletin for returns to ICU
; DATE=date of last discharge from ICU
K XMB
S XMB="BDG RETURN TO ICU" ;bulletin name
S XMB(1)=$$GET1^DIQ(2,DFN,.01) ;patient name
S XMB(2)=$$HRCN^BDGF2(DFN,DUZ(2)) ;chart number
S XMB(3)=$$GET1^DIQ(405,+DGPMDA,.01) ;transfer date/time
S XMB(4)=$$FMTE^XLFDT(DATE) ;last disch from ICU
S XMB(5)=$$GET1^DIQ(405,+DGPMCA,.1) ;admitting dx
; treating specialty
S XMB(6)=$$GET1^DIQ(405,+$$PRIORTXN^BDGF1(+DGPMA,DGPMCA,DFN),.09)
S X="NOW",%DT="T" D ^%DT S XMDT=Y ;send bulletin now
D ^XMB Q
;
TO ; -- bulletin for transfers out to other facility
D GEN ;set general variables
S XMB="BDG TRANSFER OUT DISCH" ;bulletin name
S XMB(4)=$$GET1^DIQ(405,+DGPMDA,.01) ;dsch date
S XMB(5)=$$GET1^DIQ(405,+DGPMDA,.05) ;transfer facility
S XMB(6)=$$GET1^DIQ(405,+DGPMCA,.1) ;admitting dx
S XMB(7)=$$LASTSRVN^BDGF1(DGPMCA,DFN) ;service
D ^XMB Q
;
AMA ; -- bulletin for ama discharges
D GEN ;set general variables
S XMB="BDG AMA DISCHARGE" ;bulletin name
S XMB(4)=$$GET1^DIQ(405,+DGPMDA,.01) ;dsch date
S XMB(5)=$$GET1^DIQ(405,+DGPMCA,.1) ;admitting dx
;
;IHS/ITSC/LJF 4/9/2004 fixed parameters
;S XMB(6)=$$LASTSRVN^BDGF1(DGPMCA,DFN) ;service
S XMB(7)=$$LASTSRVN^BDGF1(DGPMCA,DFN) ;service
S XMB(6)=$$GET1^DIQ(405,+DGPMDA,.01) ;dsch date
;IHS/ITSC/LJF end of changes
;
D ^XMB Q
;
DEATH ; -- bulletin for inpatient death
D GEN ;set gen variables
S XMB="BDG DEATH" ;bulletin name
S XMB(4)=$$GET1^DIQ(405,+DGPMDA,.01) ;dsch date
S XMB(5)=$$GET1^DIQ(405,+DGPMDA,.04) ;dsch type
S XMB(6)=$$GET1^DIQ(405,+DGPMCA,.1) ;admitting dx
S XMB(7)=$$LASTSRVN^BDGF1(DGPMCA,DFN) ;service
D ^XMB Q
;
ONEDAY ; bulletin for one day admits
D GEN ;set gen variables
S XMB="BDG ONEDAY ADMIT" ;bulletin name
S XMB(4)=$$GET1^DIQ(405,+DGPMDA,.01) ;dsch date
S XMB(5)=$$GET1^DIQ(405,+DGPMDA,.04) ;dsch type
S XMB(6)=$$GET1^DIQ(405,+DGPMCA,.1) ;admitting dx
S XMB(7)=$$LASTSRVN^BDGF1(DGPMCA,DFN) ;service
D ^XMB Q
;
LASTDX(DATE) ; -- find last adm dx
NEW Y S Y=$O(^DGPM("APTT3",DFN,DATE,0)) I 'Y Q ""
S Y=$$GET1^DIQ(405,Y,.14,"I") ;admit movement
Q $$GET1^DIQ(405,+Y,.1)
;
LASTSRV(DATE) ; returns disch service for last admission
NEW Y S Y=$O(^DGPM("APTT3",DFN,DATE,0)) I 'Y Q ""
S Y=$$GET1^DIQ(405,Y,.14,"I") ;admit movement
Q $$LASTSRVN^BDGF1(+Y,DFN)
;
LASTICU(ADM,DATE) ; returns date of last discharge from ICU
NEW D,FOUND,LAST,N
S FOUND=0
S D=DATE F S D=$O(^DGPM("APCA",DFN,ADM,D),-1) Q:'D Q:FOUND D
. S N=$O(^DGPM("APCA",DFN,ADM,D,0)) Q:'N
. ; if this transfer was to an ICU ward, quit search
. ;I $$GET1^DIQ(42,$$GET1^DIQ(405,N,.06,"I"),101)="YES" S FOUND=1
. I $$GET1^DIQ(9009016.5,$$GET1^DIQ(405,N,.06,"I"),101)="YES" S FOUND=1 Q ;IHS/ITSC/LJF 4/9/2004
. S LAST=N
;
; if previous ICU transfer found, return date of transfer out of ICU
I FOUND,$G(LAST) Q $$GET1^DIQ(405,LAST,.01,"I")
Q ""
;
READM24(ADM,PAT) ; returns 1 if patient readmitted within 24 hours
NEW ADMDT,LAST,DIFF
S ADMDT=$$GET1^DIQ(405,ADM,.01,"I") ;new admit date
S LAST=$O(^DGPM("APTT3",PAT,ADMDT),-1) ;last discharge
I 'LAST Q 0 ;1st admission
S DIFF=$$FMDIFF^XLFDT(ADMDT,LAST,2)\3600 ;# of hrs diff
I DIFF>24 Q 0 ;beyond 24 hrs
S Y=$O(^DGPM("APTT3",PAT,LAST,0)) I 'Y Q 0 ;last disch ien
S Y=$$GET1^DIQ(405,Y,.14,"I") I 'Y Q 0 ;last admission ien;IHS/ITSC/LJF 4/9/2004
;
; if same service, then call bulletin (return 1 and last disch date)
I $$LASTSRVN^BDGF1(Y,PAT)=$$ADMSRV^BDGF1(ADM,PAT) Q 1_U_LAST
Q 0
BDGBULL1 ; IHS/ANMC/LJF - POST ADT BULLETINS ;
+1 ;;5.3;PIMS;**1007,1013**;FEB 27, 2007
+2 ; Called by ADT Event Driver protocol
+3 ;
+4 ; Input Variables:
+5 ; DGPMT = type of event (1-admit, 3-discharge, etc.)
+6 ; DGPMDA = event ien
+7 ; DGPMCA = admission ien
+8 ; DGPMP = zero node of 405 entry Prior to event
+9 ; DGPMA = zero node of 405 entry After event
+10 ; DFN = patient ien
+11 ; DGQUIET = if $G(DGQUIET), no user interaction
+12 ;
+13 ;
+14 ;cmi/anch/maw 2/22/2007 added code OBS and code in EVENT to send bulletin if a patient goes from observation to admission PATCH 1007 item 1007.43
+15 ;ihs/cmi/maw 04/08/2011 PATCH 1013 RQMT157 added code for delete admit reason
+16 ;
EVENT ; process event type
+1 NEW DIV
SET DIV=$$DIV^BDGPAR(DUZ(2))
IF 'DIV
QUIT
+2 ;
+3 ; admission event
+4 IF DGPMT=1
Begin DoDot:1
+5 ; check if transfer in from another facility
+6 IF $$GET1^DIQ(9009020.1,DIV,101)="YES"
Begin DoDot:2
+7 NEW CODE
SET CODE=$$GET1^DIQ(405.1,+$PIECE(DGPMA,U,4),9999999.1)
+8 IF (CODE=2)!(CODE=3)
DO TI
End DoDot:2
+9 ;
+10 ;IHS/ITSC/LJF 4/9/2004 moved code around so if admit w/in 24 hours then quit after
+11 ; check if readmitted w/24 hrs to same service (might be same admit)
+12 NEW BDGQUIT
+13 IF $$GET1^DIQ(9009020.1,DIV,114)="YES"
Begin DoDot:2
+14 SET Y=$$READM24(DGPMCA,DFN)
IF Y
SET BDGQUIT=1
DO SAMEADM($PIECE(Y,U,2))
End DoDot:2
IF $GET(BDGQUIT)
QUIT
+15 ;
+16 ; check if readmission within parameter limit
+17 IF $$GET1^DIQ(9009020.1,DIV,104)="YES"
Begin DoDot:2
+18 SET Y=$$READM^BDGF1(DGPMCA,DFN)
IF Y
DO READM($PIECE(Y,U,2))
End DoDot:2
+19 ;
+20 ; check if readmitted w/24 hrs to same service (might be same admit)
+21 ;I $$GET1^DIQ(9009020.1,DIV,114)="YES" D
+22 ;. S Y=$$READM24(DGPMCA,DFN) I Y D SAMEADM($P(Y,U,2))
+23 ;IHS/ITSC/LJF 4/9/2004 end of changes
+24 ;
+25 ; check if admit after day surgery within parameter limit
+26 IF $$GET1^DIQ(9009020.1,DIV,106)="YES"
Begin DoDot:2
+27 SET Y=$$DSADM^BDGF1(DGPMCA,DFN)
IF Y
DO ADMDS($PIECE(Y,U,2))
End DoDot:2
+28 ;
+29 ;cmi/anch/maw 2/22/2007 added bulleting if observation to admission PATCH 1007 item 1007.43
+30 ;check if observation to admission
+31 IF $$GET1^DIQ(9009020.1,DIV,115)="YES"
Begin DoDot:2
+32 IF $$LASTSRVN^BDGF1(DGPMCA,DFN)["OBSERVATION"
DO OBS
End DoDot:2
+33 ;
+34 ; check if admission was deleted
+35 IF DGPMA=""
DO DELADM
End DoDot:1
QUIT
+36 ;
+37 ; ward transfer event
+38 ;IHS/ITSC/LJF 4/9/2004 moved code around so if return to icu, only send one bulletin
+39 IF DGPMT=2
Begin DoDot:1
+40 ; check if receiving ward is an ICU
+41 IF $$GET1^DIQ(9009016.5,+$PIECE(DGPMA,U,6),101)="YES"
Begin DoDot:2
+42 NEW BDGQUIT
+43 ;
+44 ; is this a return to ICU within parameter limit?
+45 ;if bulletin turned on
IF $$GET1^DIQ(9009020.1,DIV,111)="YES"
Begin DoDot:3
+46 ;date disch from ICU
SET X=$$LASTICU(DGPMCA,+DGPMA)
IF 'X
QUIT
+47 IF $$FMDIFF^XLFDT(+DGPMA,X)'>$$GET1^DIQ(9009020.1,DIV,112)
SET BDGQUIT=1
DO RICU(X)
QUIT
End DoDot:3
IF $GET(BDGQUIT)
QUIT
+48 ;
+49 IF $$GET1^DIQ(9009020.1,DIV,110)="YES"
DO ICU
+50 ;
+51 ; is this also a return to ICU within parameter limit?
+52 ;Q:$$GET1^DIQ(9009020.1,DIV,111)'="YES" ;bulletin not turned on
+53 ;S X=$$LASTICU(DGPMCA,+DGPMA) Q:'X ;date disch from ICU
+54 ;I $$FMDIFF^XLFDT(+DGPMA,X)'>$$GET1^DIQ(9009020.1,DIV,112) D RICU(X)
End DoDot:2
End DoDot:1
QUIT
+55 ;IHS/ITSC/LJF 4/9/2004 end of changes
+56 ;
+57 ; discharge event
+58 IF DGPMT=3
Begin DoDot:1
+59 ;quit if discharge deleted
IF DGPMA=""
QUIT
+60 ;
+61 ; check if patient died
+62 IF $$GET1^DIQ(2,DFN,.351)]""
Begin DoDot:2
+63 IF $$GET1^DIQ(9009020.1,DIV,103)="YES"
DO DEATH
End DoDot:2
QUIT
+64 ;
+65 ; check if AMA discharge
+66 IF $$GET1^DIQ(405.1,$$GET1^DIQ(405,+DGPMDA,.04,"I"),9999999.1)=3
Begin DoDot:2
+67 IF $$GET1^DIQ(9009020.1,DIV,108)="YES"
DO AMA
End DoDot:2
+68 ;
+69 ; check if transfer to other facility
+70 IF $$GET1^DIQ(9009020.1,DIV,102)="YES"
Begin DoDot:2
+71 IF $$GET1^DIQ(405,+DGPMDA,.05)]""
DO TO
End DoDot:2
+72 ;
+73 ; check if LOS less than 24 hours and not observation
+74 IF $$LOSHRS^BDGF1(DGPMCA,+DGPMA,DFN)<24
Begin DoDot:2
+75 IF $$LASTSRVN^BDGF1(DGPMCA,DFN)'["OBSERVATION"
Begin DoDot:3
+76 IF $$GET1^DIQ(9009020.1,DIV,113)="YES"
DO ONEDAY
End DoDot:3
End DoDot:2
+77 ;
End DoDot:1
QUIT
+78 ;
+79 QUIT
GEN ; -- set general data
+1 ;IHS/ITSC/LJF 4/9/2004 start with clean array
KILL XMB
+2 ;patient name
SET XMB(1)=$$GET1^DIQ(2,DFN,.01)
+3 ;chart #
SET XMB(2)=$$HRCN^BDGF2(DFN,DUZ(2))
+4 ;admit date/time
SET XMB(3)=$$GET1^DIQ(405,DGPMCA,.01)
+5 ;send bulletin now
SET X="NOW"
SET %DT="T"
DO ^%DT
SET XMDT=Y
+6 QUIT
+7 ;
TI ; -- bulletin for transfers in to facility
+1 ;set general variables
DO GEN
+2 ;bulletin name
SET XMB="BDG TRANSFER IN ADMIT"
+3 ;transfer facility
SET XMB(4)=$$GET1^DIQ(405,+DGPMCA,.05)
+4 ;admitting dx
SET XMB(5)=$$GET1^DIQ(405,+DGPMCA,.1)
+5 ;service
SET XMB(6)=$$ADMSRV^BDGF1(DGPMCA,DFN)
+6 DO ^XMB
QUIT
+7 ;
OBS ; -- bulletin for observation to admission
+1 ;cmi/anch/maw 2/22/2007 added for observation to admission PATCH 1007 item 1007.43
+2 ;set general variables
DO GEN
+3 ;bulletin name
SET XMB="BDG OBS TO ADMIT"
+4 ;service
SET XMB(4)=$$ADMSRV^BDGF1(DGPMCA,DFN)
+5 ;admitting dx
SET XMB(5)=$$GET1^DIQ(405,+DGPMCA,.1)
+6 DO ^XMB
QUIT
+7 ;
READM(LAST) ; -- bulletin for readmissions
+1 ; LAST=last discharge date in FM format
+2 ;set gen vars
DO GEN
+3 ;bulletin name
SET XMB="BDG READMISSION"
+4 ;time limit
SET XMB(4)=$$GET1^DIQ(9009020.1,+$$DIV^BDGPAR(DUZ(2)),105)
+5 ;admitting dx
SET XMB(5)=$$GET1^DIQ(405,+DGPMCA,.1)
+6 ;last discharge
SET XMB(6)=$$FMTE^XLFDT(LAST)
+7 ;last adm dx
SET XMB(7)=$$LASTDX(LAST)
+8 ;new service
SET XMB(8)=$$ADMSRV^BDGF1(DGPMCA,DFN)
+9 ;last service
SET XMB(9)=$$LASTSRV(LAST)
+10 DO ^XMB
QUIT
+11 ;
SAMEADM(LAST) ; -- bulletin for readmission within 24 hrs to same service
+1 ; LAST=last discharge date in FM format
+2 ;set gen vars
DO GEN
+3 ;bulletin name
SET XMB="BDG SAME ADMIT"
+4 ;admitting dx
SET XMB(4)=$$GET1^DIQ(405,+DGPMCA,.1)
+5 ;last adm dx
SET XMB(5)=$$LASTDX(LAST)
+6 ;last discharge
SET XMB(6)=$$FMTE^XLFDT(LAST)
+7 ;new service
SET XMB(7)=$$ADMSRV^BDGF1(DGPMCA,DFN)
+8 DO ^XMB
QUIT
+9 ;
ADMDS(LAST) ; -- bulletin for admit after day surgery
+1 ; LAST=date of last day surgery
+2 ;set gen variables
DO GEN
+3 ;bulletin name
SET XMB="BDG ADMIT AFTER DAY SURG"
+4 ;time limit
SET XMB(4)=$$GET1^DIQ(9009020.1,+$$DIV^BDGPAR(DUZ(2)),107)
+5 ;adm dx
SET XMB(5)=$$GET1^DIQ(405,+DGPMCA,.1)
+6 ;day surgery date/time
SET XMB(6)=$$FMTE^XLFDT(LAST)
+7 ;adm srv
SET XMB(9)=$$ADMSRV^BDGF1(+DGPMCA,DFN)
+8 ;S Y=DGDS D DD^%DT S XMB(6)=Y ;day surg date/time;IHS/ITSC/LJF 4/9/2004
+9 ;day surg procedure
SET XMB(7)=$$DSPROC^BDGDSA(LAST,DFN)
+10 ;ds disposition
SET Y=$$DSDISP^BDGDSA(LAST,DFN)
+11 ;S XMB(8)=$S(DGDIS="ADM":"**ADMITTED DIRECTLY FROM DAY SURGERY**",1:"")
+12 ;IHS/ITSC/LJF 4/9/2004
SET XMB(8)=$SELECT(Y="ADM":"**ADMITTED DIRECTLY FROM DAY SURGERY**",1:"")
+13 DO ^XMB
QUIT
+14 ;
DELADM ; bulletin for deleted admission
+1 ;set gen variables
DO GEN
+2 ;bulletin name
SET XMB="BDG DELETED ADMITS"
+3 ;deleted admit date
SET XMB(3)=$$FMTE^XLFDT(+DGPMP)
+4 ;ward
SET XMB(4)=$$GET1^DIQ(42,+$PIECE(DGPMP,U,6),.01)
+5 ;deleted by
SET XMB(5)=$$GET1^DIQ(200,DUZ,.01)
+6 ;deleted at
SET XMB(6)=$$HTE^XLFDT($HOROLOG)
+7 ;delete reason ihs/cmi/maw 04/08/2011 Patch 1013 RQMT157
SET XMB(7)=$GET(BDGDLREA)
+8 KILL BDGDLREA
+9 DO ^XMB
QUIT
+10 ;
ICU ; -- bulletin for ICU transfers
+1 KILL XMB
+2 ;bulletin name
SET XMB="BDG ICU TRANSFER"
+3 ;patient name
SET XMB(1)=$$GET1^DIQ(2,DFN,.01)
+4 ;chart number
SET XMB(2)=$$HRCN^BDGF2(DFN,DUZ(2))
+5 ;transfer date/time
SET XMB(3)=$$GET1^DIQ(405,+DGPMDA,.01)
+6 ;admitting dx
SET XMB(4)=$$GET1^DIQ(405,+DGPMCA,.1)
+7 ; treating specialty
+8 SET XMB(5)=$$GET1^DIQ(405,+$$PRIORTXN^BDGF1(+DGPMA,DGPMCA,DFN),.09)
+9 ;send bulletin now
SET X="NOW"
SET %DT="T"
DO ^%DT
SET XMDT=Y
+10 DO ^XMB
QUIT
+11 ;
RICU(DATE) ; -- bulletin for returns to ICU
+1 ; DATE=date of last discharge from ICU
+2 KILL XMB
+3 ;bulletin name
SET XMB="BDG RETURN TO ICU"
+4 ;patient name
SET XMB(1)=$$GET1^DIQ(2,DFN,.01)
+5 ;chart number
SET XMB(2)=$$HRCN^BDGF2(DFN,DUZ(2))
+6 ;transfer date/time
SET XMB(3)=$$GET1^DIQ(405,+DGPMDA,.01)
+7 ;last disch from ICU
SET XMB(4)=$$FMTE^XLFDT(DATE)
+8 ;admitting dx
SET XMB(5)=$$GET1^DIQ(405,+DGPMCA,.1)
+9 ; treating specialty
+10 SET XMB(6)=$$GET1^DIQ(405,+$$PRIORTXN^BDGF1(+DGPMA,DGPMCA,DFN),.09)
+11 ;send bulletin now
SET X="NOW"
SET %DT="T"
DO ^%DT
SET XMDT=Y
+12 DO ^XMB
QUIT
+13 ;
TO ; -- bulletin for transfers out to other facility
+1 ;set general variables
DO GEN
+2 ;bulletin name
SET XMB="BDG TRANSFER OUT DISCH"
+3 ;dsch date
SET XMB(4)=$$GET1^DIQ(405,+DGPMDA,.01)
+4 ;transfer facility
SET XMB(5)=$$GET1^DIQ(405,+DGPMDA,.05)
+5 ;admitting dx
SET XMB(6)=$$GET1^DIQ(405,+DGPMCA,.1)
+6 ;service
SET XMB(7)=$$LASTSRVN^BDGF1(DGPMCA,DFN)
+7 DO ^XMB
QUIT
+8 ;
AMA ; -- bulletin for ama discharges
+1 ;set general variables
DO GEN
+2 ;bulletin name
SET XMB="BDG AMA DISCHARGE"
+3 ;dsch date
SET XMB(4)=$$GET1^DIQ(405,+DGPMDA,.01)
+4 ;admitting dx
SET XMB(5)=$$GET1^DIQ(405,+DGPMCA,.1)
+5 ;
+6 ;IHS/ITSC/LJF 4/9/2004 fixed parameters
+7 ;S XMB(6)=$$LASTSRVN^BDGF1(DGPMCA,DFN) ;service
+8 ;service
SET XMB(7)=$$LASTSRVN^BDGF1(DGPMCA,DFN)
+9 ;dsch date
SET XMB(6)=$$GET1^DIQ(405,+DGPMDA,.01)
+10 ;IHS/ITSC/LJF end of changes
+11 ;
+12 DO ^XMB
QUIT
+13 ;
DEATH ; -- bulletin for inpatient death
+1 ;set gen variables
DO GEN
+2 ;bulletin name
SET XMB="BDG DEATH"
+3 ;dsch date
SET XMB(4)=$$GET1^DIQ(405,+DGPMDA,.01)
+4 ;dsch type
SET XMB(5)=$$GET1^DIQ(405,+DGPMDA,.04)
+5 ;admitting dx
SET XMB(6)=$$GET1^DIQ(405,+DGPMCA,.1)
+6 ;service
SET XMB(7)=$$LASTSRVN^BDGF1(DGPMCA,DFN)
+7 DO ^XMB
QUIT
+8 ;
ONEDAY ; bulletin for one day admits
+1 ;set gen variables
DO GEN
+2 ;bulletin name
SET XMB="BDG ONEDAY ADMIT"
+3 ;dsch date
SET XMB(4)=$$GET1^DIQ(405,+DGPMDA,.01)
+4 ;dsch type
SET XMB(5)=$$GET1^DIQ(405,+DGPMDA,.04)
+5 ;admitting dx
SET XMB(6)=$$GET1^DIQ(405,+DGPMCA,.1)
+6 ;service
SET XMB(7)=$$LASTSRVN^BDGF1(DGPMCA,DFN)
+7 DO ^XMB
QUIT
+8 ;
LASTDX(DATE) ; -- find last adm dx
+1 NEW Y
SET Y=$ORDER(^DGPM("APTT3",DFN,DATE,0))
IF 'Y
QUIT ""
+2 ;admit movement
SET Y=$$GET1^DIQ(405,Y,.14,"I")
+3 QUIT $$GET1^DIQ(405,+Y,.1)
+4 ;
LASTSRV(DATE) ; returns disch service for last admission
+1 NEW Y
SET Y=$ORDER(^DGPM("APTT3",DFN,DATE,0))
IF 'Y
QUIT ""
+2 ;admit movement
SET Y=$$GET1^DIQ(405,Y,.14,"I")
+3 QUIT $$LASTSRVN^BDGF1(+Y,DFN)
+4 ;
LASTICU(ADM,DATE) ; returns date of last discharge from ICU
+1 NEW D,FOUND,LAST,N
+2 SET FOUND=0
+3 SET D=DATE
FOR
SET D=$ORDER(^DGPM("APCA",DFN,ADM,D),-1)
IF 'D
QUIT
IF FOUND
QUIT
Begin DoDot:1
+4 SET N=$ORDER(^DGPM("APCA",DFN,ADM,D,0))
IF 'N
QUIT
+5 ; if this transfer was to an ICU ward, quit search
+6 ;I $$GET1^DIQ(42,$$GET1^DIQ(405,N,.06,"I"),101)="YES" S FOUND=1
+7 ;IHS/ITSC/LJF 4/9/2004
IF $$GET1^DIQ(9009016.5,$$GET1^DIQ(405,N,.06,"I"),101)="YES"
SET FOUND=1
QUIT
+8 SET LAST=N
End DoDot:1
+9 ;
+10 ; if previous ICU transfer found, return date of transfer out of ICU
+11 IF FOUND
IF $GET(LAST)
QUIT $$GET1^DIQ(405,LAST,.01,"I")
+12 QUIT ""
+13 ;
READM24(ADM,PAT) ; returns 1 if patient readmitted within 24 hours
+1 NEW ADMDT,LAST,DIFF
+2 ;new admit date
SET ADMDT=$$GET1^DIQ(405,ADM,.01,"I")
+3 ;last discharge
SET LAST=$ORDER(^DGPM("APTT3",PAT,ADMDT),-1)
+4 ;1st admission
IF 'LAST
QUIT 0
+5 ;# of hrs diff
SET DIFF=$$FMDIFF^XLFDT(ADMDT,LAST,2)\3600
+6 ;beyond 24 hrs
IF DIFF>24
QUIT 0
+7 ;last disch ien
SET Y=$ORDER(^DGPM("APTT3",PAT,LAST,0))
IF 'Y
QUIT 0
+8 ;last admission ien;IHS/ITSC/LJF 4/9/2004
SET Y=$$GET1^DIQ(405,Y,.14,"I")
IF 'Y
QUIT 0
+9 ;
+10 ; if same service, then call bulletin (return 1 and last disch date)
+11 IF $$LASTSRVN^BDGF1(Y,PAT)=$$ADMSRV^BDGF1(ADM,PAT)
QUIT 1_U_LAST
+12 QUIT 0
