AUPNVSIT ; IHS/CMI/LAB - EDITS FOR AUPNVSIT (VISIT:9000010) 24-MAY-1993 ; 30 Sep 2010 2:13 PM
;;2.0;IHS PCC SUITE;**5,10,11**;MAY 14, 2009;Build 58
;IHS/CMI/LAB - added VCN entry point
;IHS/CMI/LAB - patch 14 added set of duz and dt to deleted visits
;fixed bgp to bdw
;
VSIT01 ;EP;9000010,.01 (VISIT,VISIT/ADMIT DATE&TIME)
I '$D(AUPNPAT) W:'$D(AUPNTALK)&('$D(ZTQUEUED)) " <No direct entry allowed>" K X Q
I $D(AUPNDOB),$D(AUPNDOD),AUPNDOB,$D(DT),DT D VSIT01B Q
I '$D(AUPNTALK),'$D(ZTQUEUED) W " <Required variables do not exist>"
K X
Q
VSIT01B ;
;added check so that chart review visits can be created after DOD
NEW S
S S=$G(APCDCAT) I S="",$G(DA) S S=$P($G(^AUPNVSIT(DA,0)),U,7)
I '$D(APCDFVOK),DT_".9999"<X W:'$D(AUPNTALK)&('$D(ZTQUEUED)) " <Future dates not allowed>" K X Q
I DUZ("AG")="I",AUPNDOD,S'="C",$P(X,".",1)>AUPNDOD W:'$D(AUPNTALK)&('$D(ZTQUEUED)) " <Patient died before this date>" K X Q
I $P(X,".",1)<AUPNDOB W:'$D(AUPNTALK)&('$D(ZTQUEUED)) " <Patient born after this date>" K X Q
Q
;
POSTSLCT ;
S AUPNVSIT=+Y,AUPNY=Y
I '$D(AUPNPAT),$P(^AUPNVSIT(AUPNVSIT,0),U,5) S Y=$P(^(0),U,5) D ^AUPNPAT
S Y=AUPNY K AUPNY
Q
;
ADD ; ADD TO DEPENDENCY COUNT
L +^AUPNVSIT(X,0):10 E W:'$D(ZTQUEUED) !!,"VISIT locked. Notify programmer!",! Q
S:$P(^AUPNVSIT(X,0),U,9)<0 $P(^(0),U,9)=0
S $P(^AUPNVSIT(X,0),U,9)=$P(^AUPNVSIT(X,0),U,9)+1 ;,$P(^(0),U,11)="" ;*** WILL NOT UNDELETE ***
I $D(^AUPNVSIT("AMFI",X)),^AUPNVSIT("AMFI",X)="M"
E I DUZ'=".5",$D(^AUTTSITE(1,0)),$P(^AUTTSITE(1,0),U,16)="V",$P(^AUPNVSIT(X,0),U,15)'="A",$P(^(0),U,15)'="D" S $P(^AUPNVSIT(X,0),U,15)="M",^AUPNVSIT("AMFI",X)="M"
L -^AUPNVSIT(X,0)
Q
SUB ; SUBTRACT FROM DEPENDENCY COUNT
L +^AUPNVSIT(X,0):10 E W:'$D(ZTQUEUED) !!,"VISIT locked. Notify programmer!",! Q
S $P(^AUPNVSIT(X,0),U,9)=$P(^AUPNVSIT(X,0),U,9)-1 ;S:$P(^(0),U,9)<1 $P(^(0),U,11)=1 *** DON'T DELETE ***
I $P(^AUPNVSIT(X,0),U,9)<0 S $P(^(0),U,9)=0 ; Should not happen but does
I $P(^AUPNVSIT(X,0),U,15)="A"
E I DUZ'=.5,$D(^AUTTSITE(1,0)),$P(^AUTTSITE(1,0),U,16)="V" S $P(^AUPNVSIT(X,0),U,15)="D",^AUPNVSIT("AMFI",X)="D"
L -^AUPNVSIT(X,0)
Q
;
MOD ;PEP;MODIFY A VISIT OR V FILE ENTRY
;*******CANNOT BE CALLED FROM DIE **********CALLS DIE
Q:$G(AUPNVSIT)=""
Q:AUPNVSIT<0
Q:'$D(^AUPNVSIT(AUPNVSIT,0))
S DA=AUPNVSIT,DIE="^AUPNVSIT(",DR=".13////"_DT D ^DIE K DA,DIE,DIU,DIV,DR
;SET FACE TO FACE MAPPING OF SNOMED
D FTF^AUPNMAP
D WHSEEN^AUPNMAP
;SET PRIMARY SNOMED BASED ON THE FOLLOWING
;IF ANY ARE MARKED AS PRIMARY, SET THAT ONE, OTHERWISE SET THE FIRST ONE
D SETPRIM^AUPNMAP
I $O(^AMERVSIT("AD",AUPNVSIT,""))]"",$T(SYNC^AMERPOV)]"" D EN^XBNEW("SYNC^AMERPOV","AUPNVSIT") ;amer/bedd
I $T(A08^BTSEVENT)]"" D A08
I $$BH(AUPNVSIT) D QBHV
;the following updates MFI information
Q:'$D(^AUTTSITE(1,0))
Q:$P(^AUTTSITE(1,0),U,16)'="V"
Q:DUZ=.5
I $P(^AUPNVSIT(AUPNVSIT,0),U,15)'="A",$P(^(0),U,15)'="D" S DR=".15///M",DA=AUPNVSIT,DIE="^AUPNVSIT(" D ^DIE
K DIE,DA,DR,DIU,DIV
Q
BH(V) ;
;is this a BH visit from EHR or PCC d/e that needs to be moved to BH?
;clinic=14, 46, 48, C4
;or provider discipline equals one of the codes in the BH PROVIDER CLASS CODE file
I $T(EN^AMHEHR)="" Q 0 ;bh patch 8 not installed yet
NEW C,%,G
S C=$$CLINIC^APCLV(V,"C")
I C=14!(C=43)!(C=48)!(C="C4")!(C="C9") Q 1 ;clinic code
S (G,%)=0
F S %=$O(^AUPNVPRV("AD",V,%)) Q:%'=+%!(G) D
.S C=$P($G(^AUPNVPRV(%,0)),U)
.Q:C=""
.S C=$P($G(^VA(200,C,"PS")),U,5)
.Q:C=""
.S C=$P($G(^DIC(7,C,9999999)),U)
.Q:C=""
.I $D(^AMHBHPC("C",C)) S G=1 ;provider class
.Q
Q G
;
QBHV ;queue BH visit creation/update to background
;if visit was created by BH then quit
Q:$T(EN^AMHEHR)=""
NEW G,ZTSK,ZTRTN,ZTSAVE,ZTDESC,ZTIO,ZTDTH
S G=$O(^AMHREC("AVISIT",AUPNVSIT,0))
I G,$P($G(^AMHREC(G,11)),U,11) Q ;this visit was created by BH
I "ACHINRT"'[$P(^AUPNVSIT(AUPNVSIT,0),U,7) Q ;only these service categories are applicable
I '$D(^AUPNVPRV("AD",AUPNVSIT)) Q
I '$D(^AUPNVPOV("AD",AUPNVSIT)) Q
I $T(EN^AMHEHR)]"" D EN^XBNEW("EN^AMHEHR","AUPNVSIT") Q
Q
;queue to background ????
Q:$T(EN^AMHEHR)=""
F %="AUPNVSIT" S ZTSAVE(%)=""
S ZTRTN="EN^AMHEHR"
S ZTDESC="BH VISIT CREATION FROM EHR/PCC"
S ZTIO=""
S ZTDTH=$H
D ^%ZTLOAD
K ZTSK
Q
;*******CANNOT BE CALLED FROM DIE**********CALLS DIE
DEL ;EP;*** EXTERNAL ENTRY POINT *** SET DELETE FLAG
; The following exclusive NEW excepted from SAC by the Director, DSD. Request dated 12.14.92. No suspense was mandated.
N (DT,DUZ,AUPNVSIT,U)
I $P(^AUPNVSIT(AUPNVSIT,0),U,9) S AUPNVSIT=-1 Q
S DIK="^AUPNVSIT(",DA=AUPNVSIT,X=2 D DD^DIK,1^DIK1
S DA=AUPNVSIT,DR=".11///1;1117////"_$$NOW^XLFDT,DIE="^AUPNVSIT(" D ^DIE K DA,DIE,DR ;IHS/CMI/LAB - ADDED DATE TO 1117
I $G(DUZ) S $P(^AUPNVSIT(AUPNVSIT,0),U,27)=DUZ ;IHS/CMI/LAB - store user who deleted in .27
I $G(DT) S $P(^AUPNVSIT(AUPNVSIT,0),U,13)=DT ;IHS/CMI/LAB - visits being deleted w dec
I $G(DT)]"" S ^AUPNVSIT("APCIS",DT,AUPNVSIT)="" ;IHS/CMI/LAB for apcp patch 6 send deletes
I $G(DT),$P($G(^BDWSITE(1,0)),U,2)]"",DT>$P(^BDWSITE(1,0),U,2) S ^AUPNVSIT("ADWO",DT,AUPNVSIT)="" ;IHS/CMI/LAB - for data warehouse deletes.
I $P($G(^AUPNVSIT(AUPNVSIT,22)),U,1)="" S $P(^AUPNVSIT(AUPNVSIT,22),U,1)="UNKNOWN/NON DATA ENTRY"
I DUZ'=.5,$D(^AUTTSITE(1,0)),$P(^AUTTSITE(1,0),U,16)="V",$P(^AUPNVSIT(AUPNVSIT,0),U,15)="A" S DA=AUPNVSIT,DR=".15///@",DIE="^AUPNVSIT(" D ^DIE K DA,DIE,DR Q
I DUZ'=.5,$D(^AUTTSITE(1,0)),$P(^AUTTSITE(1,0),U,16)="V",$P(^AUPNVSIT(AUPNVSIT,0),U,15)'="A" S DA=AUPNVSIT,DR=".15///D",DIE="^AUPNVSIT(" D ^DIE K DA,DIE,DR Q
Q
;
VCN(AUPNVSIT,AUPNADD) ;EP; *** EXTERNAL ENTRY POINT ***
; Returns Visit Control Number (VCN) on visit if already there
; Creates VCN and adds to visit if AUPNADD set to 1
; Returns a number if VCN found or created; returns "" if not
; If asked to add VCN and failed, 2nd piece VCN = error code:msg
;
; VCN = patient ien + . + running count for patient+1 + last digit of pseudo code for the site (ex. 234.56)
; Running count for patient is stored in ^AUPNVSIT("AVCN",DFN)
;
; Due to call to DICN an exclusive NEW is used
;
NEW X
I '$G(AUPNVSIT) Q $S($G(AUPNADD)=1:"^1:INVALID VISIT IEN",1:"")
S X=$P($G(^AUPNVSIT(AUPNVSIT,11)),U,3) I X Q X ;VCN already there
I $G(AUPNADD)'=1 Q X ;return result if add not an option
;
NEW (DT,DUZ,U,AUPNVSIT,AUPNADD) ;SAC Exemption on file as of August 31, 2007 per email from Mike Danielson
Q:'$G(^AUPNVSIT(AUPNVSIT,0)) "^1:INVALID VISIT IEN"
Q:$P(^AUPNVSIT(AUPNVSIT,0),U,11)=1 "^2:DELETED VISIT"
S DFN=$P(^AUPNVSIT(AUPNVSIT,0),U,5) Q:'DFN "^3:INVALID PATIENT ON VISIT"
Q:'$G(^AUPNPAT(DFN,0)) "^3:INVALID PATIENT ON VISIT"
; Q:"ASORH"'[$P(^AUPNVSIT(AUPNVSIT,0),U,7) "^4:INVALID SERVICE CATEGORY" ;IHS/ASDST/GTH AUPN*99.1*7 02/15/2002
;Q:"ASORHT"'[$P(^AUPNVSIT(AUPNVSIT,0),U,7) "^4:INVALID SERVICE CATEGORY" ;add telephone per ANMC;IHS/ASDST/GTH AUPN*99.1*7 02/15/2002;IHS/SET/GTH AUPN*99.1*8 10/04/2002
Q:"ASORHTC"'[$P(^AUPNVSIT(AUPNVSIT,0),U,7) "^4:INVALID SERVICE CATEGORY" ;add telephone per ANMC;IHS/ASDST/GTH AUPN*99.1*7 02/15/2002;IHS/SET/GTH AUPN*99.1*8 10/04/2002
;
;if vcn already exists, add to count until a good one is found
;S COUNT=$P(^AUPNPAT(DFN,0),U,37) ;last VCN
;F S COUNT=COUNT+1 Q:COUNT>99999 Q:'$D(^AUPNVSIT("VCN",DFN_"."_COUNT))
S COUNT=+$G(^AUPNVSIT("AVCN",DFN))
S ALPHA=$$ALPHA(AUPNVSIT) I ALPHA="" Q "^7:NO PSEUDO PREFIX FOR SITE"
I ALPHA=+ALPHA Q "^8:INVALID PSEUDO PREFIX FOR SITE"
F S COUNT=COUNT+1 Q:'$D(^AUPNVSIT("VCN",DFN_"."_COUNT_ALPHA))
I COUNT>99999 Q "^5:LAST VCN INVALID"
S AUPNVCN=DFN_"."_COUNT_ALPHA
;
S DIE="^AUPNVSIT(",DA=AUPNVSIT,DR="1103///"_AUPNVCN D ^DIE
I $P($G(^AUPNVSIT(AUPNVSIT,11)),U,3)'=AUPNVCN Q "^6:DIE CALL FAILED:"_AUPNVCN
Q AUPNVCN
;
ALPHA(VISIT) ; - returns 3rd character of pseudo prefix form encounter location
NEW X
S X=$P($G(^AUPNVSIT(+$G(VISIT),0)),U,6) I 'X Q ""
Q $E($P($G(^AUTTLOC(X,1)),U,2),3)
;
;begin new code IHS/ASDST/GTH AUPN*99.1*7 02/15/2002
UID(VISIT) ;EP - generate unique ID for visit
I '$G(VISIT) Q VISIT
NEW X
I '$P($G(^AUTTSITE(1,1)),"^",3) S $P(^AUTTSITE(1,1),"^",3)=$P(^AUTTLOC($P(^AUTTSITE(1,0),"^",1),0),"^",10)
S X=$P(^AUTTSITE(1,1),"^",3)
Q X_$$LZERO(VISIT,10)
;
LZERO(V,L) ;EP - left zero fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V="0"_V
Q V
;end new code IHS/ASDST/GTH AUPN*99.1*7 02/15/2002
;
INACLOC(Y) ;EP - return 1 if inactive, 0 if active
I $G(Y)="" Q 1
;check to see if location of encounter is inactive based on visit date
NEW X
S X=$$CHKLOC(Y)
I $D(^AUTTLOC(Y))
Q X
CHKLOC(Y) ; SCREEN OUT E CODES AND INACTIVE CODES
I $D(DIFGLINE) Q 0
I $D(ACHSDIEN) Q 0
I $G(DUZ("AG"))'="I" Q 0
NEW A,I,D
S I=$P(^AUTTLOC(Y,0),U,21) ;inactive date
S D="" I $G(APCDVSIT),$D(^AUPNVSIT(APCDVSIT)) S D=$P($P(^AUPNVSIT(APCDVSIT,0),U),".")
;check date if have date
I $G(APCDDATE),I]"",APCDDATE>I Q 1 ;have date, date after inactive date
I D]"",I]"",D>I Q 1
;if have no date to check then check 21st piece
I '$G(APCDVSIT),'$G(APCDDATE),$P(^AUTTLOC(Y,0),U,21) Q 1
Q 0
;
A08 ;EP - for BTS per Christy Smith, Daou 5/12/05
Q:'$G(AUPNVSIT)
S AUPNHLER=$$A08^BTSEVENT(AUPNVSIT)
K AUPNHLER
Q
;
MFI(Y) ;EP - called to determine whether a visit is an MFI visit
I 'Y Q ""
I '$D(^AUPNVSIT(Y)) Q ""
I $D(DIFGLINE) Q 1
I $P($G(^AUPNVSIT(Y,11)),U,13) Q 1
I $P($G(^AUPNVSIT(Y,0)),U,23)=.5 Q 1
Q ""
;
UIDV(VISIT) ;EP - generate unique ID for visit
I '$G(VISIT) Q VISIT
NEW X
;I '$P($G(^AUTTSITE(1,1)),"^",3) S $P(^AUTTSITE(1,1),"^",3)=$P(^AUTTLOC($P(^AUTTSITE(1,0),"^",1),0),"^",10)
S X=$$GET1^DIQ(9999999.06,$P(^AUTTSITE(1,0),U),.32)
I X="" S X="00000"
Q X_$$LZERO(VISIT,10)
AUPNVSIT ; IHS/CMI/LAB - EDITS FOR AUPNVSIT (VISIT:9000010) 24-MAY-1993 ; 30 Sep 2010 2:13 PM
+1 ;;2.0;IHS PCC SUITE;**5,10,11**;MAY 14, 2009;Build 58
+2 ;IHS/CMI/LAB - added VCN entry point
+3 ;IHS/CMI/LAB - patch 14 added set of duz and dt to deleted visits
+4 ;fixed bgp to bdw
+5 ;
VSIT01 ;EP;9000010,.01 (VISIT,VISIT/ADMIT DATE&TIME)
+1 IF '$DATA(AUPNPAT)
IF '$DATA(AUPNTALK)&('$DATA(ZTQUEUED))
WRITE " <No direct entry allowed>"
KILL X
QUIT
+2 IF $DATA(AUPNDOB)
IF $DATA(AUPNDOD)
IF AUPNDOB
IF $DATA(DT)
IF DT
DO VSIT01B
QUIT
+3 IF '$DATA(AUPNTALK)
IF '$DATA(ZTQUEUED)
WRITE " <Required variables do not exist>"
+4 KILL X
+5 QUIT
VSIT01B ;
+1 ;added check so that chart review visits can be created after DOD
+2 NEW S
+3 SET S=$GET(APCDCAT)
IF S=""
IF $GET(DA)
SET S=$PIECE($GET(^AUPNVSIT(DA,0)),U,7)
+4 IF '$DATA(APCDFVOK)
IF DT_".9999"<X
IF '$DATA(AUPNTALK)&('$DATA(ZTQUEUED))
WRITE " <Future dates not allowed>"
KILL X
QUIT
+5 IF DUZ("AG")="I"
IF AUPNDOD
IF S'="C"
IF $PIECE(X,".",1)>AUPNDOD
IF '$DATA(AUPNTALK)&('$DATA(ZTQUEUED))
WRITE " <Patient died before this date>"
KILL X
QUIT
+6 IF $PIECE(X,".",1)<AUPNDOB
IF '$DATA(AUPNTALK)&('$DATA(ZTQUEUED))
WRITE " <Patient born after this date>"
KILL X
QUIT
+7 QUIT
+8 ;
POSTSLCT ;
+1 SET AUPNVSIT=+Y
SET AUPNY=Y
+2 IF '$DATA(AUPNPAT)
IF $PIECE(^AUPNVSIT(AUPNVSIT,0),U,5)
SET Y=$PIECE(^(0),U,5)
DO ^AUPNPAT
+3 SET Y=AUPNY
KILL AUPNY
+4 QUIT
+5 ;
ADD ; ADD TO DEPENDENCY COUNT
+1 LOCK +^AUPNVSIT(X,0):10
IF '$TEST
IF '$DATA(ZTQUEUED)
WRITE !!,"VISIT locked. Notify programmer!",!
QUIT
+2 IF $PIECE(^AUPNVSIT(X,0),U,9)<0
SET $PIECE(^(0),U,9)=0
+3 ;,$P(^(0),U,11)="" ;*** WILL NOT UNDELETE ***
SET $PIECE(^AUPNVSIT(X,0),U,9)=$PIECE(^AUPNVSIT(X,0),U,9)+1
+4 IF $DATA(^AUPNVSIT("AMFI",X))
IF ^AUPNVSIT("AMFI",X)="M"
+5 IF '$TEST
IF DUZ'=".5"
IF $DATA(^AUTTSITE(1,0))
IF $PIECE(^AUTTSITE(1,0),U,16)="V"
IF $PIECE(^AUPNVSIT(X,0),U,15)'="A"
IF $PIECE(^(0),U,15)'="D"
SET $PIECE(^AUPNVSIT(X,0),U,15)="M"
SET ^AUPNVSIT("AMFI",X)="M"
+6 LOCK -^AUPNVSIT(X,0)
+7 QUIT
SUB ; SUBTRACT FROM DEPENDENCY COUNT
+1 LOCK +^AUPNVSIT(X,0):10
IF '$TEST
IF '$DATA(ZTQUEUED)
WRITE !!,"VISIT locked. Notify programmer!",!
QUIT
+2 ;S:$P(^(0),U,9)<1 $P(^(0),U,11)=1 *** DON'T DELETE ***
SET $PIECE(^AUPNVSIT(X,0),U,9)=$PIECE(^AUPNVSIT(X,0),U,9)-1
+3 ; Should not happen but does
IF $PIECE(^AUPNVSIT(X,0),U,9)<0
SET $PIECE(^(0),U,9)=0
+4 IF $PIECE(^AUPNVSIT(X,0),U,15)="A"
+5 IF '$TEST
IF DUZ'=.5
IF $DATA(^AUTTSITE(1,0))
IF $PIECE(^AUTTSITE(1,0),U,16)="V"
SET $PIECE(^AUPNVSIT(X,0),U,15)="D"
SET ^AUPNVSIT("AMFI",X)="D"
+6 LOCK -^AUPNVSIT(X,0)
+7 QUIT
+8 ;
MOD ;PEP;MODIFY A VISIT OR V FILE ENTRY
+1 ;*******CANNOT BE CALLED FROM DIE **********CALLS DIE
+2 IF $GET(AUPNVSIT)=""
QUIT
+3 IF AUPNVSIT<0
QUIT
+4 IF '$DATA(^AUPNVSIT(AUPNVSIT,0))
QUIT
+5 SET DA=AUPNVSIT
SET DIE="^AUPNVSIT("
SET DR=".13////"_DT
DO ^DIE
KILL DA,DIE,DIU,DIV,DR
+6 ;SET FACE TO FACE MAPPING OF SNOMED
+7 DO FTF^AUPNMAP
+8 DO WHSEEN^AUPNMAP
+9 ;SET PRIMARY SNOMED BASED ON THE FOLLOWING
+10 ;IF ANY ARE MARKED AS PRIMARY, SET THAT ONE, OTHERWISE SET THE FIRST ONE
+11 DO SETPRIM^AUPNMAP
+12 ;amer/bedd
IF $ORDER(^AMERVSIT("AD",AUPNVSIT,""))]""
IF $TEXT(SYNC^AMERPOV)]""
DO EN^XBNEW("SYNC^AMERPOV","AUPNVSIT")
+13 IF $TEXT(A08^BTSEVENT)]""
DO A08
+14 IF $$BH(AUPNVSIT)
DO QBHV
+15 ;the following updates MFI information
+16 IF '$DATA(^AUTTSITE(1,0))
QUIT
+17 IF $PIECE(^AUTTSITE(1,0),U,16)'="V"
QUIT
+18 IF DUZ=.5
QUIT
+19 IF $PIECE(^AUPNVSIT(AUPNVSIT,0),U,15)'="A"
IF $PIECE(^(0),U,15)'="D"
SET DR=".15///M"
SET DA=AUPNVSIT
SET DIE="^AUPNVSIT("
DO ^DIE
+20 KILL DIE,DA,DR,DIU,DIV
+21 QUIT
BH(V) ;
+1 ;is this a BH visit from EHR or PCC d/e that needs to be moved to BH?
+2 ;clinic=14, 46, 48, C4
+3 ;or provider discipline equals one of the codes in the BH PROVIDER CLASS CODE file
+4 ;bh patch 8 not installed yet
IF $TEXT(EN^AMHEHR)=""
QUIT 0
+5 NEW C,%,G
+6 SET C=$$CLINIC^APCLV(V,"C")
+7 ;clinic code
IF C=14!(C=43)!(C=48)!(C="C4")!(C="C9")
QUIT 1
+8 SET (G,%)=0
+9 FOR
SET %=$ORDER(^AUPNVPRV("AD",V,%))
IF %'=+%!(G)
QUIT
Begin DoDot:1
+10 SET C=$PIECE($GET(^AUPNVPRV(%,0)),U)
+11 IF C=""
QUIT
+12 SET C=$PIECE($GET(^VA(200,C,"PS")),U,5)
+13 IF C=""
QUIT
+14 SET C=$PIECE($GET(^DIC(7,C,9999999)),U)
+15 IF C=""
QUIT
+16 ;provider class
IF $DATA(^AMHBHPC("C",C))
SET G=1
+17 QUIT
End DoDot:1
+18 QUIT G
+19 ;
QBHV ;queue BH visit creation/update to background
+1 ;if visit was created by BH then quit
+2 IF $TEXT(EN^AMHEHR)=""
QUIT
+3 NEW G,ZTSK,ZTRTN,ZTSAVE,ZTDESC,ZTIO,ZTDTH
+4 SET G=$ORDER(^AMHREC("AVISIT",AUPNVSIT,0))
+5 ;this visit was created by BH
IF G
IF $PIECE($GET(^AMHREC(G,11)),U,11)
QUIT
+6 ;only these service categories are applicable
IF "ACHINRT"'[$PIECE(^AUPNVSIT(AUPNVSIT,0),U,7)
QUIT
+7 IF '$DATA(^AUPNVPRV("AD",AUPNVSIT))
QUIT
+8 IF '$DATA(^AUPNVPOV("AD",AUPNVSIT))
QUIT
+9 IF $TEXT(EN^AMHEHR)]""
DO EN^XBNEW("EN^AMHEHR","AUPNVSIT")
QUIT
+10 QUIT
+11 ;queue to background ????
+12 IF $TEXT(EN^AMHEHR)=""
QUIT
+13 FOR %="AUPNVSIT"
SET ZTSAVE(%)=""
+14 SET ZTRTN="EN^AMHEHR"
+15 SET ZTDESC="BH VISIT CREATION FROM EHR/PCC"
+16 SET ZTIO=""
+17 SET ZTDTH=$HOROLOG
+18 DO ^%ZTLOAD
+19 KILL ZTSK
+20 QUIT
+21 ;*******CANNOT BE CALLED FROM DIE**********CALLS DIE
DEL ;EP;*** EXTERNAL ENTRY POINT *** SET DELETE FLAG
+1 ; The following exclusive NEW excepted from SAC by the Director, DSD. Request dated 12.14.92. No suspense was mandated.
+2 NEW (DT,DUZ,AUPNVSIT,U)
+3 IF $PIECE(^AUPNVSIT(AUPNVSIT,0),U,9)
SET AUPNVSIT=-1
QUIT
+4 SET DIK="^AUPNVSIT("
SET DA=AUPNVSIT
SET X=2
DO DD^DIK
DO 1^DIK1
+5 ;IHS/CMI/LAB - ADDED DATE TO 1117
SET DA=AUPNVSIT
SET DR=".11///1;1117////"_$$NOW^XLFDT
SET DIE="^AUPNVSIT("
DO ^DIE
KILL DA,DIE,DR
+6 ;IHS/CMI/LAB - store user who deleted in .27
IF $GET(DUZ)
SET $PIECE(^AUPNVSIT(AUPNVSIT,0),U,27)=DUZ
+7 ;IHS/CMI/LAB - visits being deleted w dec
IF $GET(DT)
SET $PIECE(^AUPNVSIT(AUPNVSIT,0),U,13)=DT
+8 ;IHS/CMI/LAB for apcp patch 6 send deletes
IF $GET(DT)]""
SET ^AUPNVSIT("APCIS",DT,AUPNVSIT)=""
+9 ;IHS/CMI/LAB - for data warehouse deletes.
IF $GET(DT)
IF $PIECE($GET(^BDWSITE(1,0)),U,2)]""
IF DT>$PIECE(^BDWSITE(1,0),U,2)
SET ^AUPNVSIT("ADWO",DT,AUPNVSIT)=""
+10 IF $PIECE($GET(^AUPNVSIT(AUPNVSIT,22)),U,1)=""
SET $PIECE(^AUPNVSIT(AUPNVSIT,22),U,1)="UNKNOWN/NON DATA ENTRY"
+11 IF DUZ'=.5
IF $DATA(^AUTTSITE(1,0))
IF $PIECE(^AUTTSITE(1,0),U,16)="V"
IF $PIECE(^AUPNVSIT(AUPNVSIT,0),U,15)="A"
SET DA=AUPNVSIT
SET DR=".15///@"
SET DIE="^AUPNVSIT("
DO ^DIE
KILL DA,DIE,DR
QUIT
+12 IF DUZ'=.5
IF $DATA(^AUTTSITE(1,0))
IF $PIECE(^AUTTSITE(1,0),U,16)="V"
IF $PIECE(^AUPNVSIT(AUPNVSIT,0),U,15)'="A"
SET DA=AUPNVSIT
SET DR=".15///D"
SET DIE="^AUPNVSIT("
DO ^DIE
KILL DA,DIE,DR
QUIT
+13 QUIT
+14 ;
VCN(AUPNVSIT,AUPNADD) ;EP; *** EXTERNAL ENTRY POINT ***
+1 ; Returns Visit Control Number (VCN) on visit if already there
+2 ; Creates VCN and adds to visit if AUPNADD set to 1
+3 ; Returns a number if VCN found or created; returns "" if not
+4 ; If asked to add VCN and failed, 2nd piece VCN = error code:msg
+5 ;
+6 ; VCN = patient ien + . + running count for patient+1 + last digit of pseudo code for the site (ex. 234.56)
+7 ; Running count for patient is stored in ^AUPNVSIT("AVCN",DFN)
+8 ;
+9 ; Due to call to DICN an exclusive NEW is used
+10 ;
+11 NEW X
+12 IF '$GET(AUPNVSIT)
QUIT $SELECT($GET(AUPNADD)=1:"^1:INVALID VISIT IEN",1:"")
+13 ;VCN already there
SET X=$PIECE($GET(^AUPNVSIT(AUPNVSIT,11)),U,3)
IF X
QUIT X
+14 ;return result if add not an option
IF $GET(AUPNADD)'=1
QUIT X
+15 ;
+16 ;SAC Exemption on file as of August 31, 2007 per email from Mike Danielson
NEW (DT,DUZ,U,AUPNVSIT,AUPNADD)
+17 IF '$GET(^AUPNVSIT(AUPNVSIT,0))
QUIT "^1:INVALID VISIT IEN"
+18 IF $PIECE(^AUPNVSIT(AUPNVSIT,0),U,11)=1
QUIT "^2:DELETED VISIT"
+19 SET DFN=$PIECE(^AUPNVSIT(AUPNVSIT,0),U,5)
IF 'DFN
QUIT "^3:INVALID PATIENT ON VISIT"
+20 IF '$GET(^AUPNPAT(DFN,0))
QUIT "^3:INVALID PATIENT ON VISIT"
+21 ; Q:"ASORH"'[$P(^AUPNVSIT(AUPNVSIT,0),U,7) "^4:INVALID SERVICE CATEGORY" ;IHS/ASDST/GTH AUPN*99.1*7 02/15/2002
+22 ;Q:"ASORHT"'[$P(^AUPNVSIT(AUPNVSIT,0),U,7) "^4:INVALID SERVICE CATEGORY" ;add telephone per ANMC;IHS/ASDST/GTH AUPN*99.1*7 02/15/2002;IHS/SET/GTH AUPN*99.1*8 10/04/2002
+23 ;add telephone per ANMC;IHS/ASDST/GTH AUPN*99.1*7 02/15/2002;IHS/SET/GTH AUPN*99.1*8 10/04/2002
IF "ASORHTC"'[$PIECE(^AUPNVSIT(AUPNVSIT,0),U,7)
QUIT "^4:INVALID SERVICE CATEGORY"
+24 ;
+25 ;if vcn already exists, add to count until a good one is found
+26 ;S COUNT=$P(^AUPNPAT(DFN,0),U,37) ;last VCN
+27 ;F S COUNT=COUNT+1 Q:COUNT>99999 Q:'$D(^AUPNVSIT("VCN",DFN_"."_COUNT))
+28 SET COUNT=+$GET(^AUPNVSIT("AVCN",DFN))
+29 SET ALPHA=$$ALPHA(AUPNVSIT)
IF ALPHA=""
QUIT "^7:NO PSEUDO PREFIX FOR SITE"
+30 IF ALPHA=+ALPHA
QUIT "^8:INVALID PSEUDO PREFIX FOR SITE"
+31 FOR
SET COUNT=COUNT+1
IF '$DATA(^AUPNVSIT("VCN",DFN_"."_COUNT_ALPHA))
QUIT
+32 IF COUNT>99999
QUIT "^5:LAST VCN INVALID"
+33 SET AUPNVCN=DFN_"."_COUNT_ALPHA
+34 ;
+35 SET DIE="^AUPNVSIT("
SET DA=AUPNVSIT
SET DR="1103///"_AUPNVCN
DO ^DIE
+36 IF $PIECE($GET(^AUPNVSIT(AUPNVSIT,11)),U,3)'=AUPNVCN
QUIT "^6:DIE CALL FAILED:"_AUPNVCN
+37 QUIT AUPNVCN
+38 ;
ALPHA(VISIT) ; - returns 3rd character of pseudo prefix form encounter location
+1 NEW X
+2 SET X=$PIECE($GET(^AUPNVSIT(+$GET(VISIT),0)),U,6)
IF 'X
QUIT ""
+3 QUIT $EXTRACT($PIECE($GET(^AUTTLOC(X,1)),U,2),3)
+4 ;
+5 ;begin new code IHS/ASDST/GTH AUPN*99.1*7 02/15/2002
UID(VISIT) ;EP - generate unique ID for visit
+1 IF '$GET(VISIT)
QUIT VISIT
+2 NEW X
+3 IF '$PIECE($GET(^AUTTSITE(1,1)),"^",3)
SET $PIECE(^AUTTSITE(1,1),"^",3)=$PIECE(^AUTTLOC($PIECE(^AUTTSITE(1,0),"^",1),0),"^",10)
+4 SET X=$PIECE(^AUTTSITE(1,1),"^",3)
+5 QUIT X_$$LZERO(VISIT,10)
+6 ;
LZERO(V,L) ;EP - left zero fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V="0"_V
+3 QUIT V
+4 ;end new code IHS/ASDST/GTH AUPN*99.1*7 02/15/2002
+5 ;
INACLOC(Y) ;EP - return 1 if inactive, 0 if active
+1 IF $GET(Y)=""
QUIT 1
+2 ;check to see if location of encounter is inactive based on visit date
+3 NEW X
+4 SET X=$$CHKLOC(Y)
+5 IF $DATA(^AUTTLOC(Y))
+6 QUIT X
CHKLOC(Y) ; SCREEN OUT E CODES AND INACTIVE CODES
+1 IF $DATA(DIFGLINE)
QUIT 0
+2 IF $DATA(ACHSDIEN)
QUIT 0
+3 IF $GET(DUZ("AG"))'="I"
QUIT 0
+4 NEW A,I,D
+5 ;inactive date
SET I=$PIECE(^AUTTLOC(Y,0),U,21)
+6 SET D=""
IF $GET(APCDVSIT)
IF $DATA(^AUPNVSIT(APCDVSIT))
SET D=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")
+7 ;check date if have date
+8 ;have date, date after inactive date
IF $GET(APCDDATE)
IF I]""
IF APCDDATE>I
QUIT 1
+9 IF D]""
IF I]""
IF D>I
QUIT 1
+10 ;if have no date to check then check 21st piece
+11 IF '$GET(APCDVSIT)
IF '$GET(APCDDATE)
IF $PIECE(^AUTTLOC(Y,0),U,21)
QUIT 1
+12 QUIT 0
+13 ;
A08 ;EP - for BTS per Christy Smith, Daou 5/12/05
+1 IF '$GET(AUPNVSIT)
QUIT
+2 SET AUPNHLER=$$A08^BTSEVENT(AUPNVSIT)
+3 KILL AUPNHLER
+4 QUIT
+5 ;
MFI(Y) ;EP - called to determine whether a visit is an MFI visit
+1 IF 'Y
QUIT ""
+2 IF '$DATA(^AUPNVSIT(Y))
QUIT ""
+3 IF $DATA(DIFGLINE)
QUIT 1
+4 IF $PIECE($GET(^AUPNVSIT(Y,11)),U,13)
QUIT 1
+5 IF $PIECE($GET(^AUPNVSIT(Y,0)),U,23)=.5
QUIT 1
+6 QUIT ""
+7 ;
UIDV(VISIT) ;EP - generate unique ID for visit
+1 IF '$GET(VISIT)
QUIT VISIT
+2 NEW X
+3 ;I '$P($G(^AUTTSITE(1,1)),"^",3) S $P(^AUTTSITE(1,1),"^",3)=$P(^AUTTLOC($P(^AUTTSITE(1,0),"^",1),0),"^",10)
+4 SET X=$$GET1^DIQ(9999999.06,$PIECE(^AUTTSITE(1,0),U),.32)
+5 IF X=""
SET X="00000"
+6 QUIT X_$$LZERO(VISIT,10)
