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

BDGPCCL.m

Go to the documentation of this file. 
  1. BDGPCCL ; IHS/ANMC/LJF,WAR - PCC LINK CODE ;  [ 09/14/2004  2:11 PM ]
  1.  ;;5.3;PIMS;**1001,1003,1004,1005,1006,1010,1013,1018,1019**;MAY 28, 2004;Build 3
  1.  ;IHS/ITSC/LJF 09/01/2004 PATCH 1001 change visit pointer if "A" visit
  1.  ;IHS/ITSC/LJF 05/13/2005 PATCH 1003 HASVISIT changed to find only H visit at date/time stamp
  1.  ;             06/24/2005 PATCH 1003 fix typo so update to Discharge UB-92 works
  1.  ;             08/25/2005 PATCH 1004 fixed Discharge UB-92 to pointer with "`"
  1.  ;IHS/OIT/LJF  05/03/2006 PATCH 1005 if default visit type not set in one file, check another
  1.  ;             09/08/2006 PATCH 1006 prevent PCC visit deletion if already coded
  1.  ;cmi/anch/maw 10/20/2008 PATCH 1010 added set of APCDALVR("APCDOPT") to BDG VISIT CREATOR
  1.  ;ihs/cmi/maw  09/26/2011 PATCH 1013 added service cat and clinic for DAY SURGERY
  1.  ;IHS/OIT/CLS  03/31/2015 PATCH 1018 changed '=' to '[' DAY SURGERY to allow for subspecialties
  1.  ;
  1.  ; Called by ADT Event Driver as first 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. EVENT ; process event
  1.  Q:$$CHECK^BDGVAR(0)'=2     ;PCC link not turned on
  1.  K APCDALVR
  1.  D @DGPMT                   ;use code based on type of event
  1.  Q
  1.  ;
  1. 1 ; Admissions       
  1.  I DGPMP="",DGPMA="" Q             ;incomplete admission
  1.  I DGPMA]"",'$G(DGQUIET) D NBCHK   ;check admit date & dob for newborns
  1.  I DGPMP="" D ADDVST Q             ;new admission-create visit
  1.  I DGPMA="" D DELVST Q             ;if deleted, delete visit
  1.  I +DGPMP'=+DGPMA D CHGVDT         ;change visit date if diff adm date
  1.  ;
  1.  D CHKCAT                          ;chk serv category (H vs. O)
  1.  I +$P(DGPMA,U,17) D CHKVH         ;if discharged, check VHosp data
  1.  Q
  1.  ;
  1. 2 ; Ward Transfers
  1.  Q                                 ;no visit mods associated with wards
  1.  ;
  1. 3 ; Discharges
  1.  ;  if patient died, make sure Reg export notified
  1.  I +$G(^DPT(DFN,.35)) S ^AGPATCH($$NOW^XLFDT,DUZ(2),DFN)=""
  1.  ;
  1.  I DGPMP="" D ADDVH Q         ;if new discharge, add VHosp entry
  1.  ;
  1.  I DGPMA="" D  Q                   ;delete vhosp if disch deleted
  1.  . NEW DIK,DA,E
  1.  . S DIK=9000010.02,DA=$$VH(+$$GET1^DIQ(405,+DGPMCA,.27)) Q:'DA
  1.  . S E=$$DEL^APCDALVR(DIK,DA)      ;call PCC to delete v file
  1.  . I E,'$G(DGQUIET) D
  1.  .. W !,"ERROR DELETING V HOSP ENTRY - ERROR CODE ",E
  1.  .. W !,"Please relay this message to your supervisor"
  1.  .. D PAUSE^BDGF
  1.  ;
  1.  ; check for changes against previous discharge info
  1.  ;  if discharge date/time changed
  1.  I +DGPMA'=+DGPMP S APCDALVR("APCDDSCH")=+DGPMA
  1.  ;
  1.  ;  if discharge type changed
  1.  I $P(DGPMA,U,4)'=$P(DGPMP,U,4) S APCDALVR("APCDTDT")="`"_$P(DGPMA,U,4)
  1.  ;
  1.  ;  check for changes in UB92 field
  1.  NEW VH,X S VH=$O(^AUPNVINP("AD",+$$GET1^DIQ(405,DGPMCA,.27,"I"),0))
  1.  ;I VH S X=$$GET1^DIQ(405,DGPMDA,9999999.07,"I") I X]"",X'=$$GET1^DIQ(9000010.02,VH,6103,"I") S APCDALVR("APCDTDSU")=X
  1.  ;I VH S X=$$GET1^DIQ(405,DGPMDA,9999999.07,"I") I X]"",X'=$$GET1^DIQ(9000010.02,VH,6103,"I") S APCDALVR("APCDTDTU")=X  ;IHS/ITSC/LJF 06/24/2005 PATCH 1003
  1.  I VH S X=$$GET1^DIQ(405,DGPMDA,9999999.07,"I") I X]"",X'=$$GET1^DIQ(9000010.02,VH,6103,"I") S APCDALVR("APCDTDTU")="`"_X  ;IHS/OIT/LJF 08/25/2005 PATCH 1004
  1.  ;
  1.  ;  if transfer facility changed
  1.  I $P(DGPMA,U,5)'=$P(DGPMP,U,5) D
  1.  . I $P(DGPMA,U,5)="" S APCDALVR("APCDTTT")="@" Q
  1.  . S APCDALVR("APCDTTT")="`"_$P(DGPMA,U,5)
  1.  ;
  1.  ; if found something changed, update v hosp file
  1.  I $D(APCDALVR) D EDITVH Q
  1.  ;
  1.  D CHKCAT   ;check service category
  1.  Q
  1.  ;
  1. 4 ; check-in lodger
  1. 5 ; check-out lodger       
  1.  Q                           ;no visit mods for lodgers
  1.  ;
  1. 6 ; Service transfers
  1.  D CHKCAT                           ;service category might be changed BEFORE discharge
  1.  Q:$$GET1^DIQ(405,DGPMCA,.17)=""    ;not discharged yet
  1.  I DGPMA]"",'$G(DGQUIET) D NBCHK    ;chk newborn admit vs. dob
  1.  ;
  1.  ; check if service transfer changed discharge service
  1.  NEW VST,DSRV
  1.  S VST=$$GET1^DIQ(405,DGPMCA,.27,"I") Q:'VST
  1.  S DSRV=$P($$LASTTXN^BDGF1(DGPMCA,DFN),U,2)        ;current disch serv
  1.  I $$GET1^DIQ(9000010.02,$$VH(VST),.05,"I")'=DSRV D
  1.  . S APCDALVR("APCDTDCS")="`"_DSRV D EDITVH
  1.  ;
  1.  Q
  1.  ;
  1. ADDVST ; create visit
  1.  Q:$$HASVPTR          ;405 points to good visit
  1.  Q:$$HASVISIT         ;PCC has good visit-will add pointer
  1.  ;
  1.  S APCDALVR("APCDADD")=1              ;force add
  1.  S APCDALVR("APCDPAT")=DFN            ;patient
  1.  S APCDALVR("APCDLOC")=DUZ(2)         ;location
  1.  S APCDALVR("APCDTYPE")=$$GET1^DIQ(9001001.2,DUZ(2),.11,"I")  ;vst type
  1.  I APCDALVR("APCDTYPE")="" S APCDALVR("APCDTYPE")=$$GET1^DIQ(9001000,DUZ(2),.04,"I")  ;IHS/OIT/LJF 05/03/2006 PATCH 1005
  1.  S APCDALVR("APCDDATE")=$E(+DGPMA,1,12)    ;visit date/time, no seconds
  1.  S APCDALVR("APCDHL")=$$GET1^DIQ(42,$$GET1^DIQ(405,DGPMCA,.06,"I"),44,"I")
  1.  ;cmi/maw 9/2/2009 PATCH 1010
  1.  N BDGOPT
  1.  S BDGOPT="BDG VISIT CREATOR"
  1.  S APCDALVR("APCDOPT")=$O(^DIC(19,"B",BDGOPT,0))  ;cmi/maw 10/20/2008 PATCH 1010 added set of option used to create visit
  1.  I $G(DGQUIET) D
  1.  . S APCDALVR("AUPNTALK")=""   ;no user interaction w/PCC
  1.  . S APCDALVR("APCDANE")=""    ;no user interactive w/FM
  1.  ;
  1.  NEW ASRV S ASRV=$$LASTSRVN^BDGF1(DGPMCA,DFN)    ;admit service name
  1.  ;S APCDALVR("APCDCAT")=$S(ASRV["OBSERVATION":"O",ASRV="DAY SURGERY":"S",1:"H")   ;srv category maw 09/26/2011
  1.  S APCDALVR("APCDCAT")=$S(ASRV["OBSERVATION":"O",ASRV["DAY SURGERY":"S",1:"H")   ;srv category maw 09/26/2011; IHS/OIT/CLS 03/31/2015 patch 1018
  1.  I ASRV["OBSERVATION" S APCDALVR("APCDCLN")=$O(^DIC(40.7,"C",87,0))
  1.  ;I ASRV="DAY SURGERY" S APCDALVR("APCDCLN")=$O(^DIC(40.7,"C",44,0))  ;ihs/cmi/maw 09/26/2011 PATCH 1013
  1.  I ASRV["DAY SURGERY" S APCDALVR("APCDCLN")=$O(^DIC(40.7,"C",44,0))  ;ihs/cmi/maw 09/26/2011 PATCH 1013; IHS/OIT/CLS 03/31/2015 patch 1018
  1.  ;
  1.  D ^APCDALV
  1.  ;
  1.  I $D(APCDALVR("APCDAFLG")) D  Q
  1.  . D ERR("Error creating admit visit; code=",APCDALVR("APCDAFLG"))
  1.  . D KILLVAR
  1.  I '$G(DGQUIET) W !!,"Visit created for date of admission"
  1.  ;
  1.  L +^DGPM(DGPMCA):3 I '$T D  Q
  1.  . I '$G(DGQUIET) W !,*7,"CANNOT UPDATE VISIT LINK; ENTRY LOCKED"
  1.  . D KILLVAR
  1.  ;
  1.  ; used 4 slashes as visit at this point has no dep entry counts
  1.  S DIE="^DGPM(",DA=DGPMCA,DR=".27////"_APCDALVR("APCDVSIT")
  1.  D ^DIE L -^DGPM(DGPMCA)
  1.  ;
  1.  D KILLVAR
  1.  Q
  1.  ;
  1. EDITVST(VST,DFN)   ; edit visit data
  1.  S APCDALVR("APCDVSIT")=VST
  1.  S APCDALVR("APCDPAT")=DFN
  1.  S APCDALVR("APCDATMP")="[APCDALVR 9000010 (MOD)]"
  1.  ;
  1.  D ^APCDALVR
  1.  ;
  1.  I $D(APCDALVR("APCDAFLG")) D ERR("Error editing Visit entry; code=",APCDALVR("APCDAFLG"))
  1.  D KILLVAR
  1.  Q
  1.  ;
  1. CHGVDT ; edit visit date
  1.  K APCDCVDT
  1.  I $$GET1^DIQ(405,DGPMCA,.27)="" D ADDVST   ;if none, add visit to 405
  1.  S APCDCVDT("VISIT DFN")=$$GET1^DIQ(405,DGPMCA,.27,"I")
  1.  S APCDCVDT("VISIT DATE/TIME")=+DGPMA
  1.  ;
  1.  D START^APCDCVDT
  1.  ;
  1.  I $D(APCDCVDT("ERROR FLAG")) D
  1.  . D ERR("ERROR updating visit date/time; Code=",APCDCVDT("ERROR FLAG"))
  1.  D KILLVAR
  1.  Q
  1.  ;
  1. DELVST ; delete visit
  1.  S APCDVDLT=$P(DGPMP,U,27) Q:'APCDVDLT
  1.  I $D(^SRF("AV",APCDVDLT)) Q   ;do not delete if used by surgery
  1.  ;
  1.  ;IHS/OIT/LJF 09/08/2006 PATCH 1006
  1.  I $D(^AUPNVINP("AD",APCDVDLT)),$$GET1^DIQ(9000010.02,+$O(^AUPNVINP("AD",APCDVDLT,0)),.15)="" D  Q   ;don't delete coded visit
  1.  . D ERR("Cannot DELETE coded PCC visit.  Use PCC to delete it.","")
  1.  ;
  1.  D EN^APCDVDLT,KILLVAR
  1.  Q
  1.  ;
  1. CHKVH ; check v hosp entry to see if admission mod changed v hosp data
  1.  ;   if admission service changed...
  1.  I $$ADMSRVN^BDGF1(DGPMCA,DFN)'=$P(DGPMA,U,9) D
  1.  . S APCDALVR("APCDTADS")="`"_$$ADMSRVN^BDGF1(DGPMCA,DFN)
  1.  . S APCDALVR("APCDTDCS")="`"_$P($$LASTTXN^BDGF1(DGPMCA,DFN),U,2)
  1.  . S APCDALVR("APCDTDCS")=$P($$LASTTXN^BDGF1(DGPMCA,DFN),U,2)
  1.  ;
  1.  ;   if admission type changed...
  1.  I $P(DGPMA,U,4)'=$P(DGPMP,U,4) S APCDALVR("APCDTAT")="`"_$P(DGPMA,U,4)
  1.  ;
  1.  NEW VH,X S VH=$O(^AUPNVINP("AD",+$$GET1^DIQ(405,DGPMCA,.27,"I"),0))
  1.  I VH S X=$$GET1^DIQ(405,DGPMCA,9999999.05,"I") I X]"",X'=$$GET1^DIQ(9000010.02,VH,6101,"I") S APCDALVR("APCDTATU")=X
  1.  I VH S X=$$GET1^DIQ(405,DGPMCA,9999999.06,"I") I X]"",X'=$$GET1^DIQ(9000010.02,VH,6102,"I") S APCDALVR("APCDTASU")="`"_X
  1.  ;
  1.  I $D(APCDALVR) D EDITVH
  1.  Q
  1.  ;
  1. CHKCAT ; called by ADDVH to check visit service category
  1.  ; if last service and service category don't match, fix category
  1.  NEW VST,DSRV,CAT
  1.  S VST=$$GET1^DIQ(405,DGPMCA,.27,"I") Q:'VST
  1.  S DSRV=$$LASTSRVN^BDGF1(DGPMCA,DFN)             ;disch service name
  1.  S CAT=$$GET1^DIQ(9000010,VST,.07,"I")           ;service category
  1.  ;
  1.  ;if visit changed from H to O, delete V Hosp entry
  1.  I DSRV["OBSERVATION",CAT="H" D  Q
  1.  . S APCDALVR("APCDCAT")="O" D EDITVST(VST,DFN)
  1.  . NEW DA,DIK S DA=$O(^AUPNVINP("AD",VST,0)) I DA S DIK="^AUPNVINP(" D ^DIK
  1.  ;
  1.  ; if visit changed from O to H, make sure has V Hosp entry if discharged
  1.  I DSRV'["OBSERVATION",CAT="O" D  Q
  1.  . S APCDALVR("APCDCAT")="H" D EDITVST(VST,DFN)
  1.  . I '$O(^AUPNVINP("AD",VST,0)),$$GET1^DIQ(405,DGPMCA,.17)]"" D ADDVH
  1.  ;I DSRV'="DAY SURGERY",CAT="S" D  Q  ;ihs/cmi/maw 09/26/2011 PATCH 1013 for day surgery
  1.  I DSRV'["DAY SURGERY",CAT="S" D  Q  ;ihs/cmi/maw 09/26/2011 PATCH 1013 for day surgery; IHS/OIT/CLS 03/31/2015 patch 1018
  1.  . S APCDALVR("APCDCAT")="H" D EDITVST(VST,DFN)
  1.  . I '$O(^AUPNVINP("AD",VST,0)),$$GET1^DIQ(405,DGPMCA,.17)]"" D ADDVH
  1.  ;
  1.  Q
  1.  ;
  1. EDITVH ; edit v hospitalization
  1.  ; -- create visit if none already for admission
  1.  NEW VST S VST=$$GET1^DIQ(405,DGPMCA,.27,"I")
  1.  I 'VST D  I 'VST D KILLVAR Q
  1.  . NEW DGPMA S DGPMA=^DGPM(DGPMCA,0) D ADDVST
  1.  . S VST=$$GET1^DIQ(405,DGPMCA,.27,"I")
  1.  ;
  1.  ; -- create v hosp if none
  1.  I '$O(^AUPNVINP("AD",+VST,0)) D ADDVH Q
  1.  ;
  1.  ; -- modify v hosp
  1.  S APCDALVR("APCDVSIT")=VST
  1.  S APCDALVR("APCDPAT")=DFN
  1.  S APCDALVR("APCDATMP")="[APCDALVR 9000010.02 (MOD)]"
  1.  S APCDALVR("APCDLOOK")="`"_$O(^AUPNVINP("AD",+VST,0))
  1.  I '$D(APCDALVR("APCDDSCH")) S APCDALVR("APCDDSCH")=+$$GET1^DIQ(405,+$$GET1^DIQ(405,DGPMCA,.17,"I"),.01,"I")
  1.  ;
  1.  D ^APCDALVR
  1.  ;
  1.  I $D(APCDALVR("APCDAFLG")) D ERR("Error editing V Hosp entry; code=",APCDALVR("APCDAFLG"))
  1.  D KILLVAR
  1.  Q
  1.  ;
  1. ADDVH ;EP; -- create v hosp
  1.  ; Also called by V Hosp fix (^BDGVHF)
  1.  NEW V
  1.  S V=$$GET1^DIQ(405,DGPMCA,.27,"I")
  1.  ;
  1.  I $$GET1^DIQ(9000010,+V,.11)="DELETED" S V=""
  1.  I "OHS"'[$$GET1^DIQ(9000010,+V,.07,"I") S V=""   ;IHS/ITSC/LJF 9/1/2004 PATCH #1001 change if linked to "A" visit
  1.  I 'V D
  1.  . S DGSAV=DGPMA,DGPMA=$G(^DGPM(DGPMCA,0))  ;reset DGPMA to admit node
  1.  . D ADDVST
  1.  . S DGPMA=DGSAV K DGSAV  ;reset DGPMA back to discharge node
  1.  . S V=$$GET1^DIQ(405,DGPMCA,.27,"I")
  1.  I 'V Q
  1.  ;
  1.  S APCDALVR("APCDVSIT")=V
  1.  ;
  1.  I $D(^AUPNVINP("AD",V)) Q                ;vhosp already in file
  1.  I $$GET1^DIQ(9000010,V,.07,"I")'="H" Q   ;only add for H visits
  1.  ;
  1.  NEW DSC S DSC=$$GET1^DIQ(405,DGPMCA,.17,"I") Q:'DSC
  1.  S APCDALVR("APCDPAT")=DFN
  1.  S APCDALVR("APCDTDT")="`"_$$GET1^DIQ(405,DSC,.04,"I")
  1.  S APCDALVR("APCDATMP")="[APCDALVR 9000010.02 (ADD)]"
  1.  S:$P(DGPMA,U,18)=10 APCDALVR("APCDTTT")="`"_$P(DGPMA,U,5)
  1.  ;
  1.  S APCDALVR("APCDLOOK")=$E($$GET1^DIQ(405,DSC,.01,"I"),1,12)
  1.  ;
  1.  S APCDALVR("APCDTDCS")="`"_$P($$LASTTXN^BDGF1(DGPMCA,DFN),U,2)
  1.  S APCDALVR("APCDTADS")="`"_$$ADMSRVN^BDGF1(DGPMCA,DFN)
  1.  S APCDALVR("APCDTAT")="`"_$$GET1^DIQ(405,DGPMCA,.04,"I")
  1.  S APCDALVR("APCDTATU")=$$GET1^DIQ(405,DGPMCA,9999999.05,"I")
  1.  S X=$$GET1^DIQ(405,DGPMCA,9999999.06,"I")
  1.  S APCDALVR("APCDTASU")=$S(X="":"",1:"`"_X)
  1.  ;S APCDALVR("APCDTDTU")=$$GET1^DIQ(405,DSC,9999999.07,"I")
  1.  S APCDALVR("APCDTDTU")="`"_$$GET1^DIQ(405,DSC,9999999.07,"I")  ;IHS/OIT/LJF 8/25/2005 PATCH 1004
  1.  ;
  1.  D ^APCDALVR
  1.  ;
  1.  I $D(APCDALVR("APCDAFLG")) D ERR("Error creating V Hosp entry; code=",APCDALVR("APCDAFLG")) I 1
  1.  E  D ERR("V Hospitalization Entry Created","")
  1.  ;
  1.  D KILLVAR
  1.  Q
  1.  ;
  1. KILLVAR ; cleanup variables
  1.  D EN1^APCDEKL K DIE,DA,DR,APCDALVR,APCDCVDT,APCDVDLT,APCDVLDT  Q
  1.  ;
  1. ERR(MSG,ERROR) ; display error message
  1.  Q:$G(DGQUIET)
  1.  D MSG^BDGF(MSG_ERROR)
  1.  Q
  1.  ;
  1.  ;
  1. HASVPTR() ; -- returns 1 if admission already has good visit pointer
  1.  NEW X
  1.  S X=$$GET1^DIQ(405,DGPMCA,.27,"I") I 'X Q 0    ;visit pointer in 405
  1.  I '$D(^AUPNVSIT(X,0)) D DELPTR Q 0             ;bad pointer
  1.  ;
  1.  ; if 405 points to deleted visit, remove pointer
  1.  I $$GET1^DIQ(9000010,X,.11)="DELETED" D DELPTR Q 0
  1.  ;
  1.  ; if 405 points to a visit not an hosp or observation, remove pointer
  1.  S Y=$$GET1^DIQ(9000010,X,.07,"I") I (Y'="H"),(Y'="O"),(Y'="S") D DELPTR Q 0  ;PATCH 1019 added screen of day surgery
  1.  ;
  1.  Q 1
  1.  ;
  1. HASVISIT() ; returns 1 if visit found in PCC and link added
  1.  ; assumes called with DGPMA=admit node
  1.  NEW X,VST,CAT,DIE,DA,DR
  1.  NEW NODE S NODE=$G(^DGPM(DGPMCA,0)) I 'NODE Q 0
  1.  S X=9999999-($P(+NODE,"."))_"."_$E($P(+NODE,".",2),1,4)  ;inverse admit date without seconds
  1.  ;
  1.  ;IHS/ITSC/LJF 5/13/2005 PATCH 1003 find H visit at date/time
  1.  ;S VST=$O(^AUPNVSIT("AA",DFN,X,0)) I 'VST Q 0       ;no vst for dt/time
  1.  NEW V S (V,VST)=0 F  S V=$O(^AUPNVSIT("AA",DFN,X,V)) Q:'V  Q:VST  D
  1.  . I $P(^AUPNVSIT(V,0),U,7)="H" S VST=V
  1.  I 'VST Q 0
  1.  ;PATCH 1003 end of code changes
  1.  ;
  1.  S CAT=$P($G(^AUPNVSIT(VST,0)),U,7) I CAT="" Q 0    ;service category
  1.  I "SOH"'[CAT Q 0                                   ;must be one of these 3 to link
  1.  ;
  1.  ; update service category based on last service
  1.  S X=$$LASTSRVN^BDGF1(DGPMCA,DFN) Q:X=""
  1.  K DIE,DR,DA S DIE="^AUPNVSIT(",DA=VST
  1.  S DR=".07///"_$S(X["OBSERVATION":"O",1:"H") D ^DIE
  1.  ;
  1.  ; link visit to file 405 entry
  1.  ;   used 4 slashes to override visit file screen
  1.  K DIE,DA,DR S DIE="^DGPM(",DA=DGPMCA,DR=".27////"_VST D ^DIE
  1.  Q 1
  1.  ;
  1. VH(V) ; return V Hosp entry for visit V
  1.  Q +$O(^AUPNVINP("AD",+$$GET1^DIQ(405,DGPMCA,.27,"I"),0))
  1.  ;
  1. DELPTR ; deletes visit pointer in admission ien
  1.  NEW DIE,DA,DR S DIE="^DGPM(",DA=DGPMCA,DR=".27///@" D ^DIE
  1.  Q
  1.  ;
  1. NBCHK ; -- checks newborn admit date against date of birth 
  1.  NEW X,DOB,Y
  1.  S X=$O(^DIC(45.7,"CIHS","07",0)) I X="" Q  ;no nb code
  1.  S Y=$S(DGPMT=1:$$ADMTXN^BDGF1(DGPMCA,DFN),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