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