Routine: AMERPCC1

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

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

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

AMERPCC1.m