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

AUPNVSIT.m

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