Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BDGBULL1

BDGBULL1.m

Go to the documentation of this file. 
  1. BDGBULL1 ; IHS/ANMC/LJF - POST ADT BULLETINS ;  
  1.  ;;5.3;PIMS;**1007,1013**;FEB 27, 2007
  1.  ; Called by ADT Event Driver protocol
  1.  ;
  1.  ; Input Variables:
  1.  ;    DGPMT   = type of event (1-admit, 3-discharge, etc.)
  1.  ;    DGPMDA  = event ien
  1.  ;    DGPMCA  = admission ien
  1.  ;    DGPMP   = zero node of 405 entry Prior to event
  1.  ;    DGPMA   = zero node of 405 entry After event
  1.  ;    DFN     = patient ien
  1.  ;    DGQUIET = if $G(DGQUIET), no user interaction
  1.  ;
  1.  ;
  1.  ;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
  1.  ;ihs/cmi/maw 04/08/2011 PATCH 1013 RQMT157 added code for delete admit reason
  1.  ;
  1. EVENT ; process event type
  1.  NEW DIV S DIV=$$DIV^BDGPAR(DUZ(2)) Q:'DIV
  1.  ;
  1.  ;   admission event
  1.  I DGPMT=1 D  Q
  1.  . ;  check if transfer in from another facility
  1.  . I $$GET1^DIQ(9009020.1,DIV,101)="YES" D
  1.  .. NEW CODE S CODE=$$GET1^DIQ(405.1,+$P(DGPMA,U,4),9999999.1)
  1.  .. I (CODE=2)!(CODE=3) D TI
  1.  . ;
  1.  . ;IHS/ITSC/LJF 4/9/2004 moved code around so if admit w/in 24 hours then quit after
  1.  . ;  check if readmitted w/24 hrs to same service (might be same admit)
  1.  . NEW BDGQUIT
  1.  . I $$GET1^DIQ(9009020.1,DIV,114)="YES" D  Q:$G(BDGQUIT)
  1.  .. S Y=$$READM24(DGPMCA,DFN) I Y S BDGQUIT=1 D SAMEADM($P(Y,U,2))
  1.  . ;
  1.  . ;  check if readmission within parameter limit
  1.  . I $$GET1^DIQ(9009020.1,DIV,104)="YES" D
  1.  .. S Y=$$READM^BDGF1(DGPMCA,DFN) I Y D READM($P(Y,U,2))
  1.  . ;
  1.  . ;  check if readmitted w/24 hrs to same service (might be same admit)
  1.  . ;I $$GET1^DIQ(9009020.1,DIV,114)="YES" D
  1.  . ;. S Y=$$READM24(DGPMCA,DFN) I Y D SAMEADM($P(Y,U,2))
  1.  . ;IHS/ITSC/LJF 4/9/2004 end of changes
  1.  . ;
  1.  . ;  check if admit after day surgery within parameter limit
  1.  . I $$GET1^DIQ(9009020.1,DIV,106)="YES" D
  1.  .. S Y=$$DSADM^BDGF1(DGPMCA,DFN) I Y D ADMDS($P(Y,U,2))
  1.  . ;
  1.  . ;cmi/anch/maw 2/22/2007 added bulleting if observation to admission PATCH 1007 item 1007.43
  1.  . ;check if observation to admission
  1.  . I $$GET1^DIQ(9009020.1,DIV,115)="YES" D
  1.  .. I $$LASTSRVN^BDGF1(DGPMCA,DFN)["OBSERVATION" D OBS
  1.  . ;
  1.  . ;  check if admission was deleted
  1.  . I DGPMA="" D DELADM
  1.  ;
  1.  ; ward transfer event
  1.  ;IHS/ITSC/LJF 4/9/2004 moved code around so if return to icu, only send one bulletin
  1.  I DGPMT=2 D  Q
  1.  . ;  check if receiving ward is an ICU
  1.  . I $$GET1^DIQ(9009016.5,+$P(DGPMA,U,6),101)="YES" D
  1.  .. NEW BDGQUIT
  1.  .. ;
  1.  .. ; is this a return to ICU within parameter limit?
  1.  .. I $$GET1^DIQ(9009020.1,DIV,111)="YES" D  Q:$G(BDGQUIT)     ;if bulletin turned on
  1.  ... S X=$$LASTICU(DGPMCA,+DGPMA) Q:'X          ;date disch from ICU
  1.  ... I $$FMDIFF^XLFDT(+DGPMA,X)'>$$GET1^DIQ(9009020.1,DIV,112) S BDGQUIT=1 D RICU(X) Q
  1.  .. ;
  1.  .. I $$GET1^DIQ(9009020.1,DIV,110)="YES" D ICU
  1.  .. ;
  1.  .. ; is this also a return to ICU within parameter limit?
  1.  .. ;Q:$$GET1^DIQ(9009020.1,DIV,111)'="YES"     ;bulletin not turned on
  1.  .. ;S X=$$LASTICU(DGPMCA,+DGPMA) Q:'X          ;date disch from ICU
  1.  .. ;I $$FMDIFF^XLFDT(+DGPMA,X)'>$$GET1^DIQ(9009020.1,DIV,112) D RICU(X)
  1.  ;IHS/ITSC/LJF 4/9/2004 end of changes
  1.  ;
  1.  ; discharge event
  1.  I DGPMT=3 D  Q
  1.  . Q:DGPMA=""       ;quit if discharge deleted
  1.  . ;
  1.  . ; check if patient died
  1.  . I $$GET1^DIQ(2,DFN,.351)]"" D  Q
  1.  .. I $$GET1^DIQ(9009020.1,DIV,103)="YES" D DEATH
  1.  . ;
  1.  . ; check if AMA discharge
  1.  . I $$GET1^DIQ(405.1,$$GET1^DIQ(405,+DGPMDA,.04,"I"),9999999.1)=3 D
  1.  .. I $$GET1^DIQ(9009020.1,DIV,108)="YES" D AMA
  1.  . ;
  1.  . ; check if transfer to other facility
  1.  . I $$GET1^DIQ(9009020.1,DIV,102)="YES" D
  1.  .. I $$GET1^DIQ(405,+DGPMDA,.05)]"" D TO
  1.  . ;
  1.  . ; check if LOS less than 24 hours and not observation
  1.  . I $$LOSHRS^BDGF1(DGPMCA,+DGPMA,DFN)<24 D
  1.  .. I $$LASTSRVN^BDGF1(DGPMCA,DFN)'["OBSERVATION" D
  1.  ... I $$GET1^DIQ(9009020.1,DIV,113)="YES" D ONEDAY
  1.  . ;
  1.  ;
  1.  Q
  1. GEN ; -- set general data
  1.  K XMB   ;IHS/ITSC/LJF 4/9/2004 start with clean array
  1.  S XMB(1)=$$GET1^DIQ(2,DFN,.01)                ;patient name
  1.  S XMB(2)=$$HRCN^BDGF2(DFN,DUZ(2))             ;chart #
  1.  S XMB(3)=$$GET1^DIQ(405,DGPMCA,.01)           ;admit date/time
  1.  S X="NOW",%DT="T" D ^%DT S XMDT=Y             ;send bulletin now
  1.  Q
  1.  ;
  1. TI ; -- bulletin for transfers in to facility
  1.  D GEN                                           ;set general variables
  1.  S XMB="BDG TRANSFER IN ADMIT"                   ;bulletin name
  1.  S XMB(4)=$$GET1^DIQ(405,+DGPMCA,.05)            ;transfer facility
  1.  S XMB(5)=$$GET1^DIQ(405,+DGPMCA,.1)             ;admitting dx
  1.  S XMB(6)=$$ADMSRV^BDGF1(DGPMCA,DFN)             ;service
  1.  D ^XMB Q
  1.  ;
  1. OBS ; -- bulletin for observation to admission
  1.  ;cmi/anch/maw 2/22/2007 added for observation to admission PATCH 1007 item 1007.43
  1.  D GEN                                           ;set general variables
  1.  S XMB="BDG OBS TO ADMIT"                        ;bulletin name
  1.  S XMB(4)=$$ADMSRV^BDGF1(DGPMCA,DFN)             ;service
  1.  S XMB(5)=$$GET1^DIQ(405,+DGPMCA,.1)             ;admitting dx
  1.  D ^XMB Q
  1.  ;
  1. READM(LAST) ; -- bulletin for readmissions
  1.  ; LAST=last discharge date in FM format
  1.  D GEN                                                    ;set gen vars
  1.  S XMB="BDG READMISSION"                                  ;bulletin name
  1.  S XMB(4)=$$GET1^DIQ(9009020.1,+$$DIV^BDGPAR(DUZ(2)),105)  ;time limit
  1.  S XMB(5)=$$GET1^DIQ(405,+DGPMCA,.1)             ;admitting dx
  1.  S XMB(6)=$$FMTE^XLFDT(LAST)                     ;last discharge
  1.  S XMB(7)=$$LASTDX(LAST)                         ;last adm dx
  1.  S XMB(8)=$$ADMSRV^BDGF1(DGPMCA,DFN)             ;new service
  1.  S XMB(9)=$$LASTSRV(LAST)                        ;last service
  1.  D ^XMB Q
  1.  ;
  1. SAMEADM(LAST) ; -- bulletin for readmission within 24 hrs to same service
  1.  ; LAST=last discharge date in FM format
  1.  D GEN                                           ;set gen vars
  1.  S XMB="BDG SAME ADMIT"                          ;bulletin name
  1.  S XMB(4)=$$GET1^DIQ(405,+DGPMCA,.1)             ;admitting dx
  1.  S XMB(5)=$$LASTDX(LAST)                         ;last adm dx
  1.  S XMB(6)=$$FMTE^XLFDT(LAST)                     ;last discharge
  1.  S XMB(7)=$$ADMSRV^BDGF1(DGPMCA,DFN)             ;new service
  1.  D ^XMB Q
  1.  ;
  1. ADMDS(LAST) ; -- bulletin for admit after day surgery
  1.  ; LAST=date of last day surgery
  1.  D GEN                                           ;set gen variables
  1.  S XMB="BDG ADMIT AFTER DAY SURG"                ;bulletin name
  1.  S XMB(4)=$$GET1^DIQ(9009020.1,+$$DIV^BDGPAR(DUZ(2)),107)  ;time limit
  1.  S XMB(5)=$$GET1^DIQ(405,+DGPMCA,.1)             ;adm dx
  1.  S XMB(6)=$$FMTE^XLFDT(LAST)                     ;day surgery date/time
  1.  S XMB(9)=$$ADMSRV^BDGF1(+DGPMCA,DFN)            ;adm srv
  1.  ;S Y=DGDS D DD^%DT S XMB(6)=Y                    ;day surg date/time;IHS/ITSC/LJF 4/9/2004
  1.  S XMB(7)=$$DSPROC^BDGDSA(LAST,DFN)               ;day surg procedure
  1.  S Y=$$DSDISP^BDGDSA(LAST,DFN)                    ;ds disposition
  1.  ;S XMB(8)=$S(DGDIS="ADM":"**ADMITTED DIRECTLY FROM DAY SURGERY**",1:"")
  1.  S XMB(8)=$S(Y="ADM":"**ADMITTED DIRECTLY FROM DAY SURGERY**",1:"")  ;IHS/ITSC/LJF 4/9/2004
  1.  D ^XMB Q
  1.  ;
  1. DELADM ; bulletin for deleted admission
  1.  D GEN                                           ;set gen variables
  1.  S XMB="BDG DELETED ADMITS"                      ;bulletin name
  1.  S XMB(3)=$$FMTE^XLFDT(+DGPMP)                   ;deleted admit date
  1.  S XMB(4)=$$GET1^DIQ(42,+$P(DGPMP,U,6),.01)      ;ward
  1.  S XMB(5)=$$GET1^DIQ(200,DUZ,.01)                ;deleted by
  1.  S XMB(6)=$$HTE^XLFDT($H)                        ;deleted at
  1.  S XMB(7)=$G(BDGDLREA)                           ;delete reason ihs/cmi/maw 04/08/2011 Patch 1013 RQMT157
  1.  K BDGDLREA
  1.  D ^XMB Q
  1.  ;
  1. ICU ; -- bulletin for ICU transfers
  1.  K XMB
  1.  S XMB="BDG ICU TRANSFER"                        ;bulletin name
  1.  S XMB(1)=$$GET1^DIQ(2,DFN,.01)                  ;patient name
  1.  S XMB(2)=$$HRCN^BDGF2(DFN,DUZ(2))               ;chart number
  1.  S XMB(3)=$$GET1^DIQ(405,+DGPMDA,.01)            ;transfer date/time
  1.  S XMB(4)=$$GET1^DIQ(405,+DGPMCA,.1)             ;admitting dx
  1.  ; treating specialty
  1.  S XMB(5)=$$GET1^DIQ(405,+$$PRIORTXN^BDGF1(+DGPMA,DGPMCA,DFN),.09)
  1.  S X="NOW",%DT="T" D ^%DT S XMDT=Y               ;send bulletin now
  1.  D ^XMB Q
  1.  ;
  1. RICU(DATE) ; -- bulletin for returns to ICU
  1.  ; DATE=date of last discharge from ICU
  1.  K XMB
  1.  S XMB="BDG RETURN TO ICU"                       ;bulletin name
  1.  S XMB(1)=$$GET1^DIQ(2,DFN,.01)                  ;patient name
  1.  S XMB(2)=$$HRCN^BDGF2(DFN,DUZ(2))               ;chart number
  1.  S XMB(3)=$$GET1^DIQ(405,+DGPMDA,.01)            ;transfer date/time
  1.  S XMB(4)=$$FMTE^XLFDT(DATE)                     ;last disch from ICU
  1.  S XMB(5)=$$GET1^DIQ(405,+DGPMCA,.1)             ;admitting dx
  1.  ; treating specialty
  1.  S XMB(6)=$$GET1^DIQ(405,+$$PRIORTXN^BDGF1(+DGPMA,DGPMCA,DFN),.09)
  1.  S X="NOW",%DT="T" D ^%DT S XMDT=Y               ;send bulletin now
  1.  D ^XMB Q
  1.  ;
  1. TO ; -- bulletin for transfers out to other facility
  1.  D GEN                                           ;set general variables
  1.  S XMB="BDG TRANSFER OUT DISCH"                  ;bulletin name
  1.  S XMB(4)=$$GET1^DIQ(405,+DGPMDA,.01)            ;dsch date
  1.  S XMB(5)=$$GET1^DIQ(405,+DGPMDA,.05)            ;transfer facility
  1.  S XMB(6)=$$GET1^DIQ(405,+DGPMCA,.1)             ;admitting dx
  1.  S XMB(7)=$$LASTSRVN^BDGF1(DGPMCA,DFN)           ;service
  1.  D ^XMB Q
  1.  ;
  1. AMA ; -- bulletin for ama discharges
  1.  D GEN                                           ;set general variables
  1.  S XMB="BDG AMA DISCHARGE"                       ;bulletin name
  1.  S XMB(4)=$$GET1^DIQ(405,+DGPMDA,.01)            ;dsch date
  1.  S XMB(5)=$$GET1^DIQ(405,+DGPMCA,.1)             ;admitting dx
  1.  ;
  1.  ;IHS/ITSC/LJF 4/9/2004 fixed parameters
  1.  ;S XMB(6)=$$LASTSRVN^BDGF1(DGPMCA,DFN)           ;service
  1.  S XMB(7)=$$LASTSRVN^BDGF1(DGPMCA,DFN)           ;service
  1.  S XMB(6)=$$GET1^DIQ(405,+DGPMDA,.01)            ;dsch date
  1.  ;IHS/ITSC/LJF end of changes
  1.  ;
  1.  D ^XMB Q
  1.  ;
  1. DEATH ; -- bulletin for inpatient death
  1.  D GEN                                           ;set gen variables
  1.  S XMB="BDG DEATH"                               ;bulletin name
  1.  S XMB(4)=$$GET1^DIQ(405,+DGPMDA,.01)            ;dsch date
  1.  S XMB(5)=$$GET1^DIQ(405,+DGPMDA,.04)            ;dsch type
  1.  S XMB(6)=$$GET1^DIQ(405,+DGPMCA,.1)             ;admitting dx
  1.  S XMB(7)=$$LASTSRVN^BDGF1(DGPMCA,DFN)           ;service
  1.  D ^XMB Q
  1.  ;
  1. ONEDAY ; bulletin for one day admits
  1.  D GEN                                           ;set gen variables
  1.  S XMB="BDG ONEDAY ADMIT"                        ;bulletin name
  1.  S XMB(4)=$$GET1^DIQ(405,+DGPMDA,.01)            ;dsch date
  1.  S XMB(5)=$$GET1^DIQ(405,+DGPMDA,.04)            ;dsch type
  1.  S XMB(6)=$$GET1^DIQ(405,+DGPMCA,.1)             ;admitting dx
  1.  S XMB(7)=$$LASTSRVN^BDGF1(DGPMCA,DFN)           ;service
  1.  D ^XMB Q
  1.  ;
  1. LASTDX(DATE) ; -- find last adm dx
  1.  NEW Y S Y=$O(^DGPM("APTT3",DFN,DATE,0)) I 'Y Q ""
  1.  S Y=$$GET1^DIQ(405,Y,.14,"I")           ;admit movement
  1.  Q $$GET1^DIQ(405,+Y,.1)
  1.  ;
  1. LASTSRV(DATE) ; returns disch service for last admission
  1.  NEW Y S Y=$O(^DGPM("APTT3",DFN,DATE,0)) I 'Y Q ""
  1.  S Y=$$GET1^DIQ(405,Y,.14,"I")           ;admit movement
  1.  Q $$LASTSRVN^BDGF1(+Y,DFN)
  1.  ;
  1. LASTICU(ADM,DATE) ; returns date of last discharge from ICU
  1.  NEW D,FOUND,LAST,N
  1.  S FOUND=0
  1.  S D=DATE F  S D=$O(^DGPM("APCA",DFN,ADM,D),-1) Q:'D  Q:FOUND  D
  1.  . S N=$O(^DGPM("APCA",DFN,ADM,D,0)) Q:'N
  1.  . ; if this transfer was to an ICU ward, quit search
  1.  . ;I $$GET1^DIQ(42,$$GET1^DIQ(405,N,.06,"I"),101)="YES" S FOUND=1
  1.  . I $$GET1^DIQ(9009016.5,$$GET1^DIQ(405,N,.06,"I"),101)="YES" S FOUND=1 Q   ;IHS/ITSC/LJF 4/9/2004
  1.  . S LAST=N
  1.  ;
  1.  ; if previous ICU transfer found, return date of transfer out of ICU
  1.  I FOUND,$G(LAST) Q $$GET1^DIQ(405,LAST,.01,"I")
  1.  Q ""
  1.  ;
  1. READM24(ADM,PAT) ; returns 1 if patient readmitted within 24 hours
  1.  NEW ADMDT,LAST,DIFF
  1.  S ADMDT=$$GET1^DIQ(405,ADM,.01,"I")                 ;new admit date
  1.  S LAST=$O(^DGPM("APTT3",PAT,ADMDT),-1)              ;last discharge
  1.  I 'LAST Q 0                                         ;1st admission
  1.  S DIFF=$$FMDIFF^XLFDT(ADMDT,LAST,2)\3600            ;# of hrs diff
  1.  I DIFF>24 Q 0                                       ;beyond 24 hrs
  1.  S Y=$O(^DGPM("APTT3",PAT,LAST,0)) I 'Y Q 0          ;last disch ien
  1.  S Y=$$GET1^DIQ(405,Y,.14,"I") I 'Y Q 0              ;last admission ien;IHS/ITSC/LJF 4/9/2004
  1.  ;
  1.  ; if same service, then call bulletin (return 1 and last disch date)
  1.  I $$LASTSRVN^BDGF1(Y,PAT)=$$ADMSRV^BDGF1(ADM,PAT) Q 1_U_LAST
  1.  Q 0