AMERPCC1 ; IHS/OIT/SCR - SUPPORTING ROUTINES FOR PCC VISIT CREATION AND V PROVIDER EDITING ;
;;3.0;ER VISIT SYSTEM;**1,2**;FEB 23, 2009
;
SYNCHPRV(AMERDA,AMERPCC,AMERPAT) ; EP from AMERPCC
; INPUT
; AMERDA : IEN OF ER VISIT FILE
; AMERPCC : IEN OF VISIT FILE being broght in synch
; AMERPAT : IEN OF PATIENT FILE for selected ER VISIT
N AMERVERR,AMERFND,AMEREVAL,AMERETIM,AMERVPRV
N AMERPROV,AMERTIME,AMERCNT,AMERLIST,AMERCNUM,AMERVIEN
; This routine updates V PROVIDER entires with provider information in ER VISIT file
; First get any providers that are in V PROVIDER
K APCLV
S AMERLIST=""
S AMERVERR=$$PCCVF^APCLV(AMERPCC,"PROVIDER","5;13;16")
; This will return:
; APCLV(x)=internal value of provider entry^PROVIDER NAME^primary or secondary
; for each V PROVIDER x in the file for this visit
; now set the FOURTH piece to the "provider time" and
; set the FIFTH piece to "status" code for each of these providers
S AMERVPRV=0,AMERVIEN=""
F S AMERVPRV=$O(APCLV(AMERVPRV)) Q:AMERVPRV="" D
.;IHS/OIT/SCR 05.29/09 added "^" to global reference - patch 1 t2 build
.S $P(APCLV(AMERVPRV),U,4)=$P($G(^AUPNVSIT(AMERPCC,12)),U,1) ;The fourth piece is the Provider time
.S $P(APCLV(AMERVPRV),U,5)=$P($G(^AUPNVSIT(AMERPCC,0)),U,5) ;The fifth piece is the provider status - will be null unless this is a consultant for this visit
.; Now add the V PROVIDER ien to the array using a custom lookup
.S AMERVIEN=$$VPRVIEN^AMERVSIT(AMERPCC,$P(APCLV(AMERVPRV),U,1))
.S $P(APCLV(AMERVPRV),U,6)=AMERVIEN ; The sixth piece is the ien of the V PROVIDER file
.Q
; Now build an array of the providers that exist in ER VISIT
; time can be imprecise, so send "day" of discharge for discharge provider and discharge nurse
; and collected times for admitting provider and triage nurse
S X=$P($G(^AMERVSIT(AMERDA,0)),U,1) ; X is the admission date in FM format
D H^%DTC
I $G(%H)'="" D YMD^%DTC
S AMERTIME=$G(X)
; This is the DATE of admission in FM format
S AMEREVAL(1)=$P($G(^AMERVSIT(AMERDA,6)),U,3) ; DISCHARGE PROVIDER
S AMERETIM(1)=$G(AMERTIME) ; DAY OF ADMIT
I AMEREVAL(1)'="" S AMERLIST=AMEREVAL(1)_"^"
S AMEREVAL(2)=$P($G(^AMERVSIT(AMERDA,6)),U,4) ; DISCHARGE NURSE
S AMERETIM(2)=$G(AMERTIME) ; DAY OF ADMIT
; IF DISCHARGE PROVIDER AND DISCHARGE NURSE ARE THE SAME, ONLY ADD ONE ENTRY
I AMEREVAL(1)=AMEREVAL(2) S AMEREVAL(2)="",AMERETIM(2)=""
I AMEREVAL(2)'="" S AMERLIST=AMERLIST_AMEREVAL(2)_"^"
S AMEREVAL(3)=$P($G(^AMERVSIT(AMERDA,0)),U,6) ; ADMITTING PROVIDER
S AMERETIM(3)=$P($G(^AMERVSIT(AMERDA,12)),U,1) ; ADMITTING PROVIDER TIME
; IF discharge provider is same as admitting provider, only add one entry
I AMEREVAL(1)=AMEREVAL(3) S AMEREVAL(3)=""
I AMEREVAL(3)'="" S AMERLIST=AMERLIST_AMEREVAL(3)_"^"
; If triage nurse is same as discharge provider , only add one entry
I AMEREVAL(2)=AMEREVAL(3) S AMEREVAL(3)=""
S AMEREVAL(4)=$P($G(^AMERVSIT(AMERDA,0)),U,7) ; TRIAGE NURSE
S AMERETIM(4)=$P($G(^AMERVSIT(AMERDA,12)),U,2) ; TRIAGE NURSE TIME
; If discharge provider is same as traige nurse, only add once
I AMEREVAL(1)=AMEREVAL(4) S AMEREVAL(4)=""
; If discharge nurse is same as triage nurse, only add once
I AMEREVAL(2)=AMEREVAL(4) S AMEREVAL(4)=""
; If admitting provider is same as triage nurse, only add once
I AMEREVAL(3)=AMEREVAL(4) S AMEREVAL(4)=""
I AMEREVAL(4)'="" S AMERLIST=AMERLIST_AMEREVAL(4)_"^"
; If there are ER CONSULTANTS add them to the ER PROVIDER array
I ($G(^AMERVSIT(AMERDA,19,0))'="") D
.S AMERCNUM=0
.F AMERCNT=5:1 S AMERCNUM=$O(^AMERVSIT(AMERDA,19,AMERCNUM)) Q:(AMERCNUM="B"!(AMERCNUM="")) D
..; If provider already exists in provider list, don't add it again
..S AMERFND=0
..F AMERI=1:1 S AMERPROV=$P(AMERLIST,U,AMERI) Q:(AMERPROV=""!(AMERFND=1)) D
...I AMERPROV=$P($G(^AMERVSIT(AMERDA,19,AMERCNUM,0)),U,3) S AMERFND=1
...Q
..Q:AMERFND
..S AMEREVAL(AMERCNT)=$P($G(^AMERVSIT(AMERDA,19,AMERCNUM,0)),U,3) ; ER CONSULTANT NEW PERSON
..S AMERETIM(AMERCNT)=$P($G(^AMERVSIT(AMERDA,19,AMERCNUM,0)),U,2)
..S AMERLIST=AMERLIST_AMEREVAL(AMERCNT)_"^"
..Q
.Q
D VPRVUPDT
K APCLV
Q
VPRVUPDT ;
; For each ER Provider, check to see if an entry has been made in V PROVIDER
; - If entry has been made:
; -- Compare data and update if needed
; -- Remove this provider from local array of V providers
; - If entry has not been made
; -- add V PROVIDER entry
; For each remaining V PROVIDER in local array ASK if user wants remove entry from V PROVIDER
N AMERFND,AMERPROV,AMERVPRV,AMERVDR,AMERVIEN,AMERDR,AMERVINT,AMERVNAM,AMEREINT,AMERENAM
S (AMERFND,AMERPROV,AMERVPRV)=0
S (AMERVDR,AMERVIEN)=""
F S AMERPROV=$O(AMEREVAL(AMERPROV)) Q:AMERPROV="" D
.;I $G(AMEREVAL(AMERPROV))="" S AMERFND=1 Q ;IHS/OIT/SCR 10/14/09 patch 2 beta1
.S AMERFND=0 ; Flag set to 1 if provider is later found in V PROVIDER file
.Q:AMEREVAL(AMERPROV)="" ; If there is no unique information for this provider type, quit
.F S AMERVPRV=$O(APCLV(AMERVPRV)) Q:AMERVPRV="" D
..I $P(AMEREVAL(AMERPROV),U,1)=$P(APCLV(AMERVPRV),U,1) D ; If we have found a match, update if needed
...S AMERFND=1
...; First ask user if they want update PCC discharge provider as "primary" if it isn't already
...I (AMERPROV=1&($P(APCLV(AMERVPRV),U,2)="P")) D
....;IHS/OIT/SCR 12/29/08 ask before overwriting PCC
....D EN^DDIOL("**The value for PRIMARY PROVIDER in the PCC visit file is different from ERS DISCHARGE PROVIDER**","","!!?3")
....D EN^DDIOL("PCC VISIT PRIMARY PROVIDER: "_$P($G(APCLV(AMERVPRV)),U,1))
....D EN^DDIOL("ERS DISCHARGE PROVIDER: "_AMEREVAL(2))
....S DIR(0)="SO^1:Correct PCC data using ERS data;2:Correct ERS data using PCC data"
....S DIR("A")="Which would you like to do"
....D ^DIR K DIR
....S AMERANS=+Y
....I Y=""!(Y="^")!(AMERANS=2) D
.....;UPDATE ERS DISCHARGE PROVIDER WITH THE PCC PRIMARY PROVIDER
.....S AMERNEW=$P($G(APCLV(AMERVPRV)),U,1)
.....S:AMERNEW'="" AMERDR="6.3////"_AMERNEW
.....D:AMERDR'="" DIE^AMEREDIT(AMERDA,AMERDR)
.....S AMEREVAL(1)=AMERNEW
.....Q
....I AMERANS=1 D
.....S AMERVDR=$S(AMERVDR'="":AMERVDR_";",1:"")
.....S AMERVDR=AMERVDR_".04///"_"P"
.....S AMERVIEN=$P(APCLV(AMERVPRV),U,6)
.....Q
....Q ; IF THIS IS THE PCC PRIMARY PROVIDER
...;If V PROVIDER is NOT marked secondary and is not the ER DISCHARGE provider, mark this provider "secondary"
...I $P(APCLV(AMERVPRV),U,3)'="S" D
....Q:AMERPROV=1
....S AMERVDR=$S(AMERVDR'="":AMERVDR_";",1:"")
....S AMERVDR=AMERVDR_".04///"_"S"
....S AMERVIEN=$P(APCLV(AMERVPRV),U,6)
....Q
...;Update V PROVIDER time, if different from day of admit
...I $P(APCLV(AMERVPRV),U,4)'=AMERTIME D
....S AMERVDR=$S(AMERVDR'="":AMERVDR_";",1:"")
....S AMERVDR=AMERVDR_"1201///"_AMERTIME
....S AMERVIEN=$P(APCLV(AMERVPRV),U,6)
....Q
...D:AMERVIEN'="" VPRVDIE^AMERVSIT(AMERVIEN,AMERVDR)
...K:$G(AMERVPRV)'="" APCLV(AMERVPRV) ; Remove this provider from local array
...S (AMERVDR,AMERVIEN)=""
...Q
..Q
.I AMERFND=0 D ; Add this provider if it isn't there already
..I AMERPROV=1 D
...S AMERVINT=$$PRIMPROV^APCLV(AMERPCC,"I") ;RETURNS ONE PCC PRIMARY PROVIDER
...S AMERANS=1 ;DEFAULTING TO ADD ERS PROVIDER IF THERE ARE NO PCC PROVIDERS THERE
...S AMERVNAM=""
...S:AMERVINT'="" AMERVNAM=$P($G(^VA(200,AMERVINT,0)),"^",1)
...S AMEREINT=AMEREVAL(AMERPROV)
...S AMERENAM=$P($G(^VA(200,AMEREINT,0)),"^",1)
...I AMERVINT'="" D
....D EN^DDIOL("**The value for PRIMARY PROVIDER in the PCC visit file is different from ERS DISCHARGE PROVIDER**","","!!?3")
....D EN^DDIOL("PCC VISIT PRIMARY PROVIDER: "_AMERVNAM,"","!!?3")
....D EN^DDIOL("ERS DISCHARGE PROVIDER: "_AMERENAM,"","!!?3")
....S DIR(0)="SO^1:Correct PCC data using ERS data;2:Correct ERS data using PCC data"
....S DIR("A")="Which would you like to do"
....D ^DIR K DIR
....I Y=""!(Y="^") S AMERANS=2
....E S AMERANS=+Y
....Q
...I AMERANS=2 D
....;UPDATE ERS DISCHARGE PROVIDER WITH THE PCC PRIMARY PROVIDER
....D SYNCHERD^AMERERS(AMERDA,AMERPCC)
....S AMEREVAL(1)=AMERVINT
....S AMERVPRV=""
....F S AMERVPRV=$O(APCLV(AMERVPRV)) Q:AMERVPRV="" K:$P(APCLV(AMERVPRV),"^",1)=AMERVINT APCLV(AMERVPRV)
....Q
...I AMERANS=1 D
....;DELETE THE OLD PRIMARY PROVIDER IF IT IS THERE AND REPLACE IT WITH THE ERS PRIMARY PROVIDER
....F S AMERVPRV=$O(APCLV(AMERVPRV)) Q:AMERVPRV=""!(AMERVINT="") D
.....I ($P(APCLV(AMERVPRV),U,1)=AMERVINT) D
......S AMERVIEN=$P(APCLV(AMERVPRV),U,6)
......D DELVPRV^AMERVSIT(AMERVIEN)
......Q
.....Q
....I $$ADDPRV(AMERPCC,AMEREVAL(AMERPROV),AMERETIM(AMERPROV),AMERPAT,"P","")<1 D EN^DDIOL("UNABLE TO ADD PRIMARY V PROVIDER","","!!")
....E D EN^DDIOL("** PRIMARY V PROVIDER ADDED TO PCC VISIT **","","!!?3")
....Q ;IF AMER ANS=1
...Q ;IF THIS IS ERS PRIMARY PROVIDER
..I 2<=AMERPROV&(AMERPROV<=4) D ;IF THIS IS NOT THE ERS PRIMARY PROVIDER
...;IHS/OIT/SCR 10/14/09 patch 2 beta1 QUIT IF THIS PROVIDER ALREADY EXISTS IN THE PCC V PROV FILE
...S AMERFND=0
...F S AMERVPRV=$O(APCLV(AMERVPRV)) Q:AMERVPRV="" D
....I ($P(APCLV(AMERVPRV),"^",1)=AMEREVAL(AMERPROV)) S AMERFND=1
....Q
...Q:AMERFND ;ADD PROVIDER ONLY IF IT WASN'T FOUND IN THE PCC V PROVIDER ARRAY
...I $$ADDPRV(AMERPCC,AMEREVAL(AMERPROV),AMERETIM(AMERPROV),AMERPAT,"S","")<1 D EN^DDIOL("UNABLE TO ADD SECONDARY V PROVIDER","","!!")
...E D EN^DDIOL("** SECONDARY V PROVIDER ADDED TO PCC VISIT **","","!!?3")
..I AMERPROV>4 D ; Add Consultants with status of "C"
...I $$ADDPRV(AMERPCC,AMEREVAL(AMERPROV),AMERETIM(AMERPROV),AMERPAT,"S","C")<1 D EN^DDIOL("UNABLE TO ADD CONSULTANT V PROVIDER","","!!")
...E D EN^DDIOL("** SECONDARY CONSULTANT V PROVIDER ADDED TO PCC VISIT **","","!!?3")
..;K:$G(AMERVPRV)'="" APCLV(AMERVPRV)
..Q ;IF THE PROVIDER WASN'T FOUND
.Q
; All ER PROVIDERS should now be in V PROVIDER file
; Now remove all V PROVIDER entries for providers still exiting in local V PROVIDER array
S AMERVINT=$$PRIMPROV^APCLV(AMERPCC,"I") ;RETURNS ONE PCC PRIMARY PROVIDER
F S AMERVPRV=$O(APCLV(AMERVPRV)) Q:AMERVPRV="" D
.;Q:APCLV(AMERVPRV)=AMERVINT ;DONT ASK TO REMOVE THE ENTRY WE JUST ADDED TO ERS
.;IHS/OIT/SCR 10/14/09 patch 2 beta1 - don't ask to remove a provider that is part of this visit
.Q:($P(APCLV(AMERVPRV),"^",1)=AMEREVAL(1))!($P(APCLV(AMERVPRV),"^",1)=AMEREVAL(2))!($P(APCLV(AMERVPRV),"^",1)=AMEREVAL(3))!($P(APCLV(AMERVPRV),"^",1)=AMEREVAL(4))
.D EN^DDIOL("**The following V PROVIDER entry is not represented in the ERS Visit**","","!!?3")
.D EN^DDIOL("PCC VISIT PROVIDER: "_$P(APCLV(AMERVPRV),U,2))
.S DIR(0)="SO^1:REMOVE THIS PCC V PROVIDER ENTRY;2:KEEP THIS PCC VISIT V PROVIDER ENTRY"
.S DIR("A")="Which would you like to do"
.D ^DIR K DIR
.S AMERANS=+Y
.I Y=1 D
..S AMERVIEN=$P(APCLV(AMERVPRV),U,6)
..D DELVPRV^AMERVSIT(AMERVIEN)
..D EN^DDIOL("** V PROVIDER ENTRY DELETED **","","!!?3")
..Q
.Q
Q
ADDPRV(AMERPCC,AMERPIEN,AMERTIME,AMERDFN,AMERTYPE,AMERSTAT) ; EP FROM AMERPCC
; ADD AN ENTRY TO V PROVIDER
; INPUT:
; AMERPCC - VISIT IEN
; AMERPIEN - PROVIDIER IEN
; AMERTIME - TIME OF PROVIDER
; AMERDFN - PATIENT IEN
K APCDALVR,APCDAFLE
I 'AMERPCC>0 Q 0 ; INVALID VISIT IEN
I 'AMERPIEN>0 Q 0 ; INVALID PROVIDER IEN
I 'AMERDFN>0 Q 0 ; INVALID PATIENT IEN
I $G(AMERTYPE)'="P" S AMERTYPE="S"
S APCDALVR("APCDTPRO")="`"_AMERPIEN ; PROVIDER IEN
S APCDAFLE("APCDAFLE")="9000010.06"
S APCDALVR("APCDPAT")=AMERDFN ; PATIENT IEN
S APCDALVR("APCDVSIT")=AMERPCC ; VISIT IEN
S APCDALVR("APCDTCDT")=AMERTIME ; PROVIDER TIME
I AMERSTAT="C" S APCDALVR("APCDTOA")="C"
E S APCDALVR("APCDTOA")=""
S APCDALVR("APCDTPS")=AMERTYPE
S APCDALVR("APCDATMP")="[APCDALVR 9000010.06 (ADD)]"
D EN^APCDALVR
D MOD^AUPNVSIT ; Update VISIT file with last edit when a provider is added
K APCDLVR,APCDTPRO,APCDAFLE,APCDPAT,APCDVSIT,APCDTCDT,APCDTOA,APCDTPS,APCDATMP
Q 1
PRVTHERE(AMERPRVD,AMERPCC) ;EP FROM AMERPCC1
;IHS/OIT/SCR 12/16/08 - check to see if the provider you are about to add is already in the PCC visit
;INPUT: AMERPRVD - PROVIDER IEN
; AMERPCC = VISIT FILE ien for this visit
N AMERCHCK,AMERDONE,AMERERR,AMERINDX
K APCLV
Q:$G(AMERPCC)=""
S AMERERR=$$PCCVF^APCLV(AMERPCC,"PROVIDER",5) ;SPECIFYING THE INTERNAL PROVIDER ID
I 'AMERERR D
.S AMERINDX=0,AMERDONE=0,AMERCHCK=0
.F S AMERINDX=$O(APCLV(AMERINDX)) Q:AMERDONE D
..I AMERINDX="" S AMERDONE=1 Q
..S AMERIEN=$G(APCLV(AMERINDX))
..S AMERCHCK=(AMERIEN=AMERPRVD)
..I AMERCHCK S AMERDONE=1
..Q
K APCLV
Q AMERCHCK
GETPCCPV(AMERPCC) ; EP FROM AMERD AND OTHER ROUTINES
;IHS/OIT/SCR 12/18/08
;RETURNS AN ARRAY OF PCC V PROVIDER FILE INFORMATION THAT ERS SHARES
;S AMERPCCV=$$VDTM^APCLV(AMERPCC,"I") ; PIECE 1 IS THE TIMESTAMP IN THE VISIT
;S AMERPCCV=AMERPCCV_"^"_$$PATIENT^APCLV(AMERPCC,"I") ; PIECE 2 IS THE PATIENT IEN
N AMERPRVS,AMERINDX
S AMERPRVS=""
K APCLV
S AMERERR=$$PCCVF^APCLV(AMERPCC,"PROVIDER","5;13;16") ;PROVIDER IEN;PROVIDER NAME;PRIMARY/SECONDARY
S AMERINDX=""
F S AMERINDX=$O(APCLV(AMERINDX)) Q:AMERINDX="" D
.S AMERPRVS=AMERPRVS_APCLV(AMERINDX)_"~"
.Q
K APCLV
Q AMERPRVS
AMERPCC1 ; IHS/OIT/SCR - SUPPORTING ROUTINES FOR PCC VISIT CREATION AND V PROVIDER EDITING ;
+1 ;;3.0;ER VISIT SYSTEM;**1,2**;FEB 23, 2009
+2 ;
SYNCHPRV(AMERDA,AMERPCC,AMERPAT) ; EP from AMERPCC
+1 ; INPUT
+2 ; AMERDA : IEN OF ER VISIT FILE
+3 ; AMERPCC : IEN OF VISIT FILE being broght in synch
+4 ; AMERPAT : IEN OF PATIENT FILE for selected ER VISIT
+5 NEW AMERVERR,AMERFND,AMEREVAL,AMERETIM,AMERVPRV
+6 NEW AMERPROV,AMERTIME,AMERCNT,AMERLIST,AMERCNUM,AMERVIEN
+7 ; This routine updates V PROVIDER entires with provider information in ER VISIT file
+8 ; First get any providers that are in V PROVIDER
+9 KILL APCLV
+10 SET AMERLIST=""
+11 SET AMERVERR=$$PCCVF^APCLV(AMERPCC,"PROVIDER","5;13;16")
+12 ; This will return:
+13 ; APCLV(x)=internal value of provider entry^PROVIDER NAME^primary or secondary
+14 ; for each V PROVIDER x in the file for this visit
+15 ; now set the FOURTH piece to the "provider time" and
+16 ; set the FIFTH piece to "status" code for each of these providers
+17 SET AMERVPRV=0
SET AMERVIEN=""
+18 FOR
SET AMERVPRV=$ORDER(APCLV(AMERVPRV))
IF AMERVPRV=""
QUIT
Begin DoDot:1
+19 ;IHS/OIT/SCR 05.29/09 added "^" to global reference - patch 1 t2 build
+20 ;The fourth piece is the Provider time
SET $PIECE(APCLV(AMERVPRV),U,4)=$PIECE($GET(^AUPNVSIT(AMERPCC,12)),U,1)
+21 ;The fifth piece is the provider status - will be null unless this is a consultant for this visit
SET $PIECE(APCLV(AMERVPRV),U,5)=$PIECE($GET(^AUPNVSIT(AMERPCC,0)),U,5)
+22 ; Now add the V PROVIDER ien to the array using a custom lookup
+23 SET AMERVIEN=$$VPRVIEN^AMERVSIT(AMERPCC,$PIECE(APCLV(AMERVPRV),U,1))
+24 ; The sixth piece is the ien of the V PROVIDER file
SET $PIECE(APCLV(AMERVPRV),U,6)=AMERVIEN
+25 QUIT
End DoDot:1
+26 ; Now build an array of the providers that exist in ER VISIT
+27 ; time can be imprecise, so send "day" of discharge for discharge provider and discharge nurse
+28 ; and collected times for admitting provider and triage nurse
+29 ; X is the admission date in FM format
SET X=$PIECE($GET(^AMERVSIT(AMERDA,0)),U,1)
+30 DO H^%DTC
+31 IF $GET(%H)'=""
DO YMD^%DTC
+32 SET AMERTIME=$GET(X)
+33 ; This is the DATE of admission in FM format
+34 ; DISCHARGE PROVIDER
SET AMEREVAL(1)=$PIECE($GET(^AMERVSIT(AMERDA,6)),U,3)
+35 ; DAY OF ADMIT
SET AMERETIM(1)=$GET(AMERTIME)
+36 IF AMEREVAL(1)'=""
SET AMERLIST=AMEREVAL(1)_"^"
+37 ; DISCHARGE NURSE
SET AMEREVAL(2)=$PIECE($GET(^AMERVSIT(AMERDA,6)),U,4)
+38 ; DAY OF ADMIT
SET AMERETIM(2)=$GET(AMERTIME)
+39 ; IF DISCHARGE PROVIDER AND DISCHARGE NURSE ARE THE SAME, ONLY ADD ONE ENTRY
+40 IF AMEREVAL(1)=AMEREVAL(2)
SET AMEREVAL(2)=""
SET AMERETIM(2)=""
+41 IF AMEREVAL(2)'=""
SET AMERLIST=AMERLIST_AMEREVAL(2)_"^"
+42 ; ADMITTING PROVIDER
SET AMEREVAL(3)=$PIECE($GET(^AMERVSIT(AMERDA,0)),U,6)
+43 ; ADMITTING PROVIDER TIME
SET AMERETIM(3)=$PIECE($GET(^AMERVSIT(AMERDA,12)),U,1)
+44 ; IF discharge provider is same as admitting provider, only add one entry
+45 IF AMEREVAL(1)=AMEREVAL(3)
SET AMEREVAL(3)=""
+46 IF AMEREVAL(3)'=""
SET AMERLIST=AMERLIST_AMEREVAL(3)_"^"
+47 ; If triage nurse is same as discharge provider , only add one entry
+48 IF AMEREVAL(2)=AMEREVAL(3)
SET AMEREVAL(3)=""
+49 ; TRIAGE NURSE
SET AMEREVAL(4)=$PIECE($GET(^AMERVSIT(AMERDA,0)),U,7)
+50 ; TRIAGE NURSE TIME
SET AMERETIM(4)=$PIECE($GET(^AMERVSIT(AMERDA,12)),U,2)
+51 ; If discharge provider is same as traige nurse, only add once
+52 IF AMEREVAL(1)=AMEREVAL(4)
SET AMEREVAL(4)=""
+53 ; If discharge nurse is same as triage nurse, only add once
+54 IF AMEREVAL(2)=AMEREVAL(4)
SET AMEREVAL(4)=""
+55 ; If admitting provider is same as triage nurse, only add once
+56 IF AMEREVAL(3)=AMEREVAL(4)
SET AMEREVAL(4)=""
+57 IF AMEREVAL(4)'=""
SET AMERLIST=AMERLIST_AMEREVAL(4)_"^"
+58 ; If there are ER CONSULTANTS add them to the ER PROVIDER array
+59 IF ($GET(^AMERVSIT(AMERDA,19,0))'="")
Begin DoDot:1
+60 SET AMERCNUM=0
+61 FOR AMERCNT=5:1
SET AMERCNUM=$ORDER(^AMERVSIT(AMERDA,19,AMERCNUM))
IF (AMERCNUM="B"!(AMERCNUM=""))
QUIT
Begin DoDot:2
+62 ; If provider already exists in provider list, don't add it again
+63 SET AMERFND=0
+64 FOR AMERI=1:1
SET AMERPROV=$PIECE(AMERLIST,U,AMERI)
IF (AMERPROV=""!(AMERFND=1))
QUIT
Begin DoDot:3
+65 IF AMERPROV=$PIECE($GET(^AMERVSIT(AMERDA,19,AMERCNUM,0)),U,3)
SET AMERFND=1
+66 QUIT
End DoDot:3
+67 IF AMERFND
QUIT
+68 ; ER CONSULTANT NEW PERSON
SET AMEREVAL(AMERCNT)=$PIECE($GET(^AMERVSIT(AMERDA,19,AMERCNUM,0)),U,3)
+69 SET AMERETIM(AMERCNT)=$PIECE($GET(^AMERVSIT(AMERDA,19,AMERCNUM,0)),U,2)
+70 SET AMERLIST=AMERLIST_AMEREVAL(AMERCNT)_"^"
+71 QUIT
End DoDot:2
+72 QUIT
End DoDot:1
+73 DO VPRVUPDT
+74 KILL APCLV
+75 QUIT
VPRVUPDT ;
+1 ; For each ER Provider, check to see if an entry has been made in V PROVIDER
+2 ; - If entry has been made:
+3 ; -- Compare data and update if needed
+4 ; -- Remove this provider from local array of V providers
+5 ; - If entry has not been made
+6 ; -- add V PROVIDER entry
+7 ; For each remaining V PROVIDER in local array ASK if user wants remove entry from V PROVIDER
+8 NEW AMERFND,AMERPROV,AMERVPRV,AMERVDR,AMERVIEN,AMERDR,AMERVINT,AMERVNAM,AMEREINT,AMERENAM
+9 SET (AMERFND,AMERPROV,AMERVPRV)=0
+10 SET (AMERVDR,AMERVIEN)=""
+11 FOR
SET AMERPROV=$ORDER(AMEREVAL(AMERPROV))
IF AMERPROV=""
QUIT
Begin DoDot:1
+12 ;I $G(AMEREVAL(AMERPROV))="" S AMERFND=1 Q ;IHS/OIT/SCR 10/14/09 patch 2 beta1
+13 ; Flag set to 1 if provider is later found in V PROVIDER file
SET AMERFND=0
+14 ; If there is no unique information for this provider type, quit
IF AMEREVAL(AMERPROV)=""
QUIT
+15 FOR
SET AMERVPRV=$ORDER(APCLV(AMERVPRV))
IF AMERVPRV=""
QUIT
Begin DoDot:2
+16 ; If we have found a match, update if needed
IF $PIECE(AMEREVAL(AMERPROV),U,1)=$PIECE(APCLV(AMERVPRV),U,1)
Begin DoDot:3
+17 SET AMERFND=1
+18 ; First ask user if they want update PCC discharge provider as "primary" if it isn't already
+19 IF (AMERPROV=1&($PIECE(APCLV(AMERVPRV),U,2)="P"))
Begin DoDot:4
+20 ;IHS/OIT/SCR 12/29/08 ask before overwriting PCC
+21 DO EN^DDIOL("**The value for PRIMARY PROVIDER in the PCC visit file is different from ERS DISCHARGE PROVIDER**","","!!?3")
+22 DO EN^DDIOL("PCC VISIT PRIMARY PROVIDER: "_$PIECE($GET(APCLV(AMERVPRV)),U,1))
+23 DO EN^DDIOL("ERS DISCHARGE PROVIDER: "_AMEREVAL(2))
+24 SET DIR(0)="SO^1:Correct PCC data using ERS data;2:Correct ERS data using PCC data"
+25 SET DIR("A")="Which would you like to do"
+26 DO ^DIR
KILL DIR
+27 SET AMERANS=+Y
+28 IF Y=""!(Y="^")!(AMERANS=2)
Begin DoDot:5
+29 ;UPDATE ERS DISCHARGE PROVIDER WITH THE PCC PRIMARY PROVIDER
+30 SET AMERNEW=$PIECE($GET(APCLV(AMERVPRV)),U,1)
+31 IF AMERNEW'=""
SET AMERDR="6.3////"_AMERNEW
+32 IF AMERDR'=""
DO DIE^AMEREDIT(AMERDA,AMERDR)
+33 SET AMEREVAL(1)=AMERNEW
+34 QUIT
End DoDot:5
+35 IF AMERANS=1
Begin DoDot:5
+36 SET AMERVDR=$SELECT(AMERVDR'="":AMERVDR_";",1:"")
+37 SET AMERVDR=AMERVDR_".04///"_"P"
+38 SET AMERVIEN=$PIECE(APCLV(AMERVPRV),U,6)
+39 QUIT
End DoDot:5
+40 ; IF THIS IS THE PCC PRIMARY PROVIDER
QUIT
End DoDot:4
+41 ;If V PROVIDER is NOT marked secondary and is not the ER DISCHARGE provider, mark this provider "secondary"
+42 IF $PIECE(APCLV(AMERVPRV),U,3)'="S"
Begin DoDot:4
+43 IF AMERPROV=1
QUIT
+44 SET AMERVDR=$SELECT(AMERVDR'="":AMERVDR_";",1:"")
+45 SET AMERVDR=AMERVDR_".04///"_"S"
+46 SET AMERVIEN=$PIECE(APCLV(AMERVPRV),U,6)
+47 QUIT
End DoDot:4
+48 ;Update V PROVIDER time, if different from day of admit
+49 IF $PIECE(APCLV(AMERVPRV),U,4)'=AMERTIME
Begin DoDot:4
+50 SET AMERVDR=$SELECT(AMERVDR'="":AMERVDR_";",1:"")
+51 SET AMERVDR=AMERVDR_"1201///"_AMERTIME
+52 SET AMERVIEN=$PIECE(APCLV(AMERVPRV),U,6)
+53 QUIT
End DoDot:4
+54 IF AMERVIEN'=""
DO VPRVDIE^AMERVSIT(AMERVIEN,AMERVDR)
+55 ; Remove this provider from local array
IF $GET(AMERVPRV)'=""
KILL APCLV(AMERVPRV)
+56 SET (AMERVDR,AMERVIEN)=""
+57 QUIT
End DoDot:3
+58 QUIT
End DoDot:2
+59 ; Add this provider if it isn't there already
IF AMERFND=0
Begin DoDot:2
+60 IF AMERPROV=1
Begin DoDot:3
+61 ;RETURNS ONE PCC PRIMARY PROVIDER
SET AMERVINT=$$PRIMPROV^APCLV(AMERPCC,"I")
+62 ;DEFAULTING TO ADD ERS PROVIDER IF THERE ARE NO PCC PROVIDERS THERE
SET AMERANS=1
+63 SET AMERVNAM=""
+64 IF AMERVINT'=""
SET AMERVNAM=$PIECE($GET(^VA(200,AMERVINT,0)),"^",1)
+65 SET AMEREINT=AMEREVAL(AMERPROV)
+66 SET AMERENAM=$PIECE($GET(^VA(200,AMEREINT,0)),"^",1)
+67 IF AMERVINT'=""
Begin DoDot:4
+68 DO EN^DDIOL("**The value for PRIMARY PROVIDER in the PCC visit file is different from ERS DISCHARGE PROVIDER**","","!!?3")
+69 DO EN^DDIOL("PCC VISIT PRIMARY PROVIDER: "_AMERVNAM,"","!!?3")
+70 DO EN^DDIOL("ERS DISCHARGE PROVIDER: "_AMERENAM,"","!!?3")
+71 SET DIR(0)="SO^1:Correct PCC data using ERS data;2:Correct ERS data using PCC data"
+72 SET DIR("A")="Which would you like to do"
+73 DO ^DIR
KILL DIR
+74 IF Y=""!(Y="^")
SET AMERANS=2
+75 IF '$TEST
SET AMERANS=+Y
+76 QUIT
End DoDot:4
+77 IF AMERANS=2
Begin DoDot:4
+78 ;UPDATE ERS DISCHARGE PROVIDER WITH THE PCC PRIMARY PROVIDER
+79 DO SYNCHERD^AMERERS(AMERDA,AMERPCC)
+80 SET AMEREVAL(1)=AMERVINT
+81 SET AMERVPRV=""
+82 FOR
SET AMERVPRV=$ORDER(APCLV(AMERVPRV))
IF AMERVPRV=""
QUIT
IF $PIECE(APCLV(AMERVPRV),"^",1)=AMERVINT
KILL APCLV(AMERVPRV)
+83 QUIT
End DoDot:4
+84 IF AMERANS=1
Begin DoDot:4
+85 ;DELETE THE OLD PRIMARY PROVIDER IF IT IS THERE AND REPLACE IT WITH THE ERS PRIMARY PROVIDER
+86 FOR
SET AMERVPRV=$ORDER(APCLV(AMERVPRV))
IF AMERVPRV=""!(AMERVINT="")
QUIT
Begin DoDot:5
+87 IF ($PIECE(APCLV(AMERVPRV),U,1)=AMERVINT)
Begin DoDot:6
+88 SET AMERVIEN=$PIECE(APCLV(AMERVPRV),U,6)
+89 DO DELVPRV^AMERVSIT(AMERVIEN)
+90 QUIT
End DoDot:6
+91 QUIT
End DoDot:5
+92 IF $$ADDPRV(AMERPCC,AMEREVAL(AMERPROV),AMERETIM(AMERPROV),AMERPAT,"P","")<1
DO EN^DDIOL("UNABLE TO ADD PRIMARY V PROVIDER","","!!")
+93 IF '$TEST
DO EN^DDIOL("** PRIMARY V PROVIDER ADDED TO PCC VISIT **","","!!?3")
+94 ;IF AMER ANS=1
QUIT
End DoDot:4
+95 ;IF THIS IS ERS PRIMARY PROVIDER
QUIT
End DoDot:3
+96 ;IF THIS IS NOT THE ERS PRIMARY PROVIDER
IF 2<=AMERPROV&(AMERPROV<=4)
Begin DoDot:3
+97 ;IHS/OIT/SCR 10/14/09 patch 2 beta1 QUIT IF THIS PROVIDER ALREADY EXISTS IN THE PCC V PROV FILE
+98 SET AMERFND=0
+99 FOR
SET AMERVPRV=$ORDER(APCLV(AMERVPRV))
IF AMERVPRV=""
QUIT
Begin DoDot:4
+100 IF ($PIECE(APCLV(AMERVPRV),"^",1)=AMEREVAL(AMERPROV))
SET AMERFND=1
+101 QUIT
End DoDot:4
+102 ;ADD PROVIDER ONLY IF IT WASN'T FOUND IN THE PCC V PROVIDER ARRAY
IF AMERFND
QUIT
+103 IF $$ADDPRV(AMERPCC,AMEREVAL(AMERPROV),AMERETIM(AMERPROV),AMERPAT,"S","")<1
DO EN^DDIOL("UNABLE TO ADD SECONDARY V PROVIDER","","!!")
+104 IF '$TEST
DO EN^DDIOL("** SECONDARY V PROVIDER ADDED TO PCC VISIT **","","!!?3")
End DoDot:3
+105 ; Add Consultants with status of "C"
IF AMERPROV>4
Begin DoDot:3
+106 IF $$ADDPRV(AMERPCC,AMEREVAL(AMERPROV),AMERETIM(AMERPROV),AMERPAT,"S","C")<1
DO EN^DDIOL("UNABLE TO ADD CONSULTANT V PROVIDER","","!!")
+107 IF '$TEST
DO EN^DDIOL("** SECONDARY CONSULTANT V PROVIDER ADDED TO PCC VISIT **","","!!?3")
End DoDot:3
+108 ;K:$G(AMERVPRV)'="" APCLV(AMERVPRV)
+109 ;IF THE PROVIDER WASN'T FOUND
QUIT
End DoDot:2
+110 QUIT
End DoDot:1
+111 ; All ER PROVIDERS should now be in V PROVIDER file
+112 ; Now remove all V PROVIDER entries for providers still exiting in local V PROVIDER array
+113 ;RETURNS ONE PCC PRIMARY PROVIDER
SET AMERVINT=$$PRIMPROV^APCLV(AMERPCC,"I")
+114 FOR
SET AMERVPRV=$ORDER(APCLV(AMERVPRV))
IF AMERVPRV=""
QUIT
Begin DoDot:1
+115 ;Q:APCLV(AMERVPRV)=AMERVINT ;DONT ASK TO REMOVE THE ENTRY WE JUST ADDED TO ERS
+116 ;IHS/OIT/SCR 10/14/09 patch 2 beta1 - don't ask to remove a provider that is part of this visit
+117 IF ($PIECE(APCLV(AMERVPRV),"^",1)=AMEREVAL(1))!($PIECE(APCLV(AMERVPRV),"^",1)=AMEREVAL(2))!($PIECE(APCLV(AMERVPRV),"^",1)=AMEREVAL(3))!($PIECE(APCLV(AMERVPRV),"^",1)=AMEREVAL(4))
QUIT
+118 DO EN^DDIOL("**The following V PROVIDER entry is not represented in the ERS Visit**","","!!?3")
+119 DO EN^DDIOL("PCC VISIT PROVIDER: "_$PIECE(APCLV(AMERVPRV),U,2))
+120 SET DIR(0)="SO^1:REMOVE THIS PCC V PROVIDER ENTRY;2:KEEP THIS PCC VISIT V PROVIDER ENTRY"
+121 SET DIR("A")="Which would you like to do"
+122 DO ^DIR
KILL DIR
+123 SET AMERANS=+Y
+124 IF Y=1
Begin DoDot:2
+125 SET AMERVIEN=$PIECE(APCLV(AMERVPRV),U,6)
+126 DO DELVPRV^AMERVSIT(AMERVIEN)
+127 DO EN^DDIOL("** V PROVIDER ENTRY DELETED **","","!!?3")
+128 QUIT
End DoDot:2
+129 QUIT
End DoDot:1
+130 QUIT
ADDPRV(AMERPCC,AMERPIEN,AMERTIME,AMERDFN,AMERTYPE,AMERSTAT) ; EP FROM AMERPCC
+1 ; ADD AN ENTRY TO V PROVIDER
+2 ; INPUT:
+3 ; AMERPCC - VISIT IEN
+4 ; AMERPIEN - PROVIDIER IEN
+5 ; AMERTIME - TIME OF PROVIDER
+6 ; AMERDFN - PATIENT IEN
+7 KILL APCDALVR,APCDAFLE
+8 ; INVALID VISIT IEN
IF 'AMERPCC>0
QUIT 0
+9 ; INVALID PROVIDER IEN
IF 'AMERPIEN>0
QUIT 0
+10 ; INVALID PATIENT IEN
IF 'AMERDFN>0
QUIT 0
+11 IF $GET(AMERTYPE)'="P"
SET AMERTYPE="S"
+12 ; PROVIDER IEN
SET APCDALVR("APCDTPRO")="`"_AMERPIEN
+13 SET APCDAFLE("APCDAFLE")="9000010.06"
+14 ; PATIENT IEN
SET APCDALVR("APCDPAT")=AMERDFN
+15 ; VISIT IEN
SET APCDALVR("APCDVSIT")=AMERPCC
+16 ; PROVIDER TIME
SET APCDALVR("APCDTCDT")=AMERTIME
+17 IF AMERSTAT="C"
SET APCDALVR("APCDTOA")="C"
+18 IF '$TEST
SET APCDALVR("APCDTOA")=""
+19 SET APCDALVR("APCDTPS")=AMERTYPE
+20 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.06 (ADD)]"
+21 DO EN^APCDALVR
+22 ; Update VISIT file with last edit when a provider is added
DO MOD^AUPNVSIT
+23 KILL APCDLVR,APCDTPRO,APCDAFLE,APCDPAT,APCDVSIT,APCDTCDT,APCDTOA,APCDTPS,APCDATMP
+24 QUIT 1
PRVTHERE(AMERPRVD,AMERPCC) ;EP FROM AMERPCC1
+1 ;IHS/OIT/SCR 12/16/08 - check to see if the provider you are about to add is already in the PCC visit
+2 ;INPUT: AMERPRVD - PROVIDER IEN
+3 ; AMERPCC = VISIT FILE ien for this visit
+4 NEW AMERCHCK,AMERDONE,AMERERR,AMERINDX
+5 KILL APCLV
+6 IF $GET(AMERPCC)=""
QUIT
+7 ;SPECIFYING THE INTERNAL PROVIDER ID
SET AMERERR=$$PCCVF^APCLV(AMERPCC,"PROVIDER",5)
+8 IF 'AMERERR
Begin DoDot:1
+9 SET AMERINDX=0
SET AMERDONE=0
SET AMERCHCK=0
+10 FOR
SET AMERINDX=$ORDER(APCLV(AMERINDX))
IF AMERDONE
QUIT
Begin DoDot:2
+11 IF AMERINDX=""
SET AMERDONE=1
QUIT
+12 SET AMERIEN=$GET(APCLV(AMERINDX))
+13 SET AMERCHCK=(AMERIEN=AMERPRVD)
+14 IF AMERCHCK
SET AMERDONE=1
+15 QUIT
End DoDot:2
End DoDot:1
+16 KILL APCLV
+17 QUIT AMERCHCK
GETPCCPV(AMERPCC) ; EP FROM AMERD AND OTHER ROUTINES
+1 ;IHS/OIT/SCR 12/18/08
+2 ;RETURNS AN ARRAY OF PCC V PROVIDER FILE INFORMATION THAT ERS SHARES
+3 ;S AMERPCCV=$$VDTM^APCLV(AMERPCC,"I") ; PIECE 1 IS THE TIMESTAMP IN THE VISIT
+4 ;S AMERPCCV=AMERPCCV_"^"_$$PATIENT^APCLV(AMERPCC,"I") ; PIECE 2 IS THE PATIENT IEN
+5 NEW AMERPRVS,AMERINDX
+6 SET AMERPRVS=""
+7 KILL APCLV
+8 ;PROVIDER IEN;PROVIDER NAME;PRIMARY/SECONDARY
SET AMERERR=$$PCCVF^APCLV(AMERPCC,"PROVIDER","5;13;16")
+9 SET AMERINDX=""
+10 FOR
SET AMERINDX=$ORDER(APCLV(AMERINDX))
IF AMERINDX=""
QUIT
Begin DoDot:1
+11 SET AMERPRVS=AMERPRVS_APCLV(AMERINDX)_"~"
+12 QUIT
End DoDot:1
+13 KILL APCLV
+14 QUIT AMERPRVS
