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

ADGEVNT.m

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