PXCAPRV ;ISL/dee - Translates data from the PCE Device Interface into PCE's PXK for Providers ;3/14/97
;;1.0;PCE PATIENT CARE ENCOUNTER;**27**;Aug 12, 1996
Q
;
PROVIDER(PXCAENC) ;Provider
; Variables
; PXCAPRV Pointer to the provider (200)
; PXCAPS Primary or Secondary provider for above
; PXCAATND Pointer to the Attending provider (200)
; PXCAFTER Temp used to build ^TMP(PXCAGLB,$J,"PRV",PXCANPRV,0,"AFTER")
N PXCAPRV,PXCAPS,PXCAATND,PXCAFTER
S PXCAPRV=$P(PXCAENC,"^",4)
S PXCAPS=$P(PXCAENC,"^",15)
S PXCAATND=$P(PXCAENC,"^",16)
I PXCAPRV>0 D
. S PXCAFTER=PXCAPRV_"^"
. S PXCAFTER=PXCAFTER_PXCAPAT_"^"_PXCAVSIT_"^"
. S PXCAFTER=PXCAFTER_PXCAPS_"^"
. I PXCAATND>0 D
.. I PXCAATND=PXCAPRV S PXCAFTER=PXCAFTER_"A"
.. E D ATTEND
. S PXCANPRV=PXCANPRV+1
. S ^TMP(PXCAGLB,$J,"PRV",PXCANPRV,"IEN")=""
. S ^TMP(PXCAGLB,$J,"PRV",PXCANPRV,0,"BEFORE")=""
. S ^TMP(PXCAGLB,$J,"PRV",PXCANPRV,0,"AFTER")=PXCAFTER
. S ^TMP(PXCAGLB,$J,"PRV",PXCANPRV,812,"BEFORE")=""
. S ^TMP(PXCAGLB,$J,"PRV",PXCANPRV,812,"AFTER")="^"_PXCAPKG_"^"_PXCASOR
E I PXCAATND>0 D ATTEND
Q
;
ATTEND ;Add the attending provider.
S PXCANPRV=PXCANPRV+1
S ^TMP(PXCAGLB,$J,"PRV",PXCANPRV,"IEN")=""
S ^TMP(PXCAGLB,$J,"PRV",PXCANPRV,0,"BEFORE")=""
S ^TMP(PXCAGLB,$J,"PRV",PXCANPRV,0,"AFTER")=PXCAATND_"^"_PXCAPAT_"^"_PXCAVSIT_"^S^A"
S ^TMP(PXCAGLB,$J,"PRV",PXCANPRV,812,"BEFORE")=""
S ^TMP(PXCAGLB,$J,"PRV",PXCANPRV,812,"AFTER")="^"_PXCAPKG_"^"_PXCASOR
Q
;
ANOTHPRV(PXCAAPRV) ;
;Add the provider to V Provider if they are not there.
;Quit if the provider subscript is zero
; Variables
; PXCAAPRV Pointer to the provider (200)
; PXCAINDX Subscirpt of the provider in the temp array used to
; look to see if the above provider is already know.
Q:PXCAAPRV'>0
N PXCAINDX
S PXCAINDX=0
F PXCAINDX=1:1:PXCANPRV I PXCAAPRV=+^TMP(PXCAGLB,$J,"PRV",PXCAINDX,0,"AFTER") S PXCAINDX=0 Q
Q:PXCAINDX'>0
S PXCANPRV=PXCANPRV+1
S ^TMP(PXCAGLB,$J,"PRV",PXCANPRV,"IEN")=""
S ^TMP(PXCAGLB,$J,"PRV",PXCANPRV,0,"BEFORE")=""
S ^TMP(PXCAGLB,$J,"PRV",PXCANPRV,0,"AFTER")=PXCAAPRV_"^"_PXCAPAT_"^"_PXCAVSIT_"^S"
S ^TMP(PXCAGLB,$J,"PRV",PXCANPRV,812,"BEFORE")=""
S ^TMP(PXCAGLB,$J,"PRV",PXCANPRV,812,"AFTER")="^"_PXCAPKG_"^"_PXCASOR
Q
;
PRV(PXCAPRV,PXCANPRV,PXCAIEN,PXCAERRS) ;Process the provider nodes
N PXCAINDX,PXCANEW
S PXCANEW=1
F PXCAINDX=1:1:PXCANPRV I PXCAIEN=+^TMP(PXCAGLB,$J,"PRV",PXCAINDX,0,"AFTER") S PXCANEW=0 Q
I PXCANEW D
. S (PXCANPRV,PXCAINDX)=PXCANPRV+1
. S ^TMP(PXCAGLB,$J,"PRV",PXCAINDX,"IEN")=""
. S ^TMP(PXCAGLB,$J,"PRV",PXCAINDX,0,"BEFORE")=""
. S ^TMP(PXCAGLB,$J,"PRV",PXCAINDX,0,"AFTER")=PXCAIEN_"^"_PXCAPAT_"^"_PXCAVSIT
. S ^TMP(PXCAGLB,$J,"PRV",PXCAINDX,812,"BEFORE")=""
. S ^TMP(PXCAGLB,$J,"PRV",PXCAINDX,812,"AFTER")="^"_PXCAPKG_"^"_PXCASOR
S $P(^TMP(PXCAGLB,$J,"PRV",PXCAINDX,0,"AFTER"),"^",4)=$P(PXCAPRV,"^",1)
S:$P(PXCAPRV,"^",2)]"" $P(^TMP(PXCAGLB,$J,"PRV",PXCAINDX,0,"AFTER"),"^",5)=$S($P(PXCAPRV,"^",2)=1:"A",1:"")
Q
;
PROV(PXCA,PXCABULD,PXCAERRS) ;Validate the provider nodes
Q:'$D(PXCA("PROVIDER"))
N PXCAIEN,PXCAPRV,PXCAITEM
S PXCAIEN=""
F S PXCAIEN=$O(PXCA("PROVIDER",PXCAIEN)) Q:PXCAIEN']"" D
. I '$$ACTIVPRV^PXAPI(PXCAIEN,PXCADT) S PXCA("ERROR","PROVIDER",PXCAIEN,0,0)="Provider is not active or valid^"_PXCAIEN
. S PXCAPRV=$G(PXCA("PROVIDER",PXCAIEN))
. S PXCAITEM=$P(PXCAPRV,"^",1)
. I '(PXCAITEM="P"!(PXCAITEM="S")) S PXCA("ERROR","PROVIDER",PXCAIEN,0,1)="Provider indicator code must be P|S^"_PXCAITEM
. E I PXCAITEM="P" D
.. I 'PXCAPPRV S PXCAPPRV=PXCAIEN
.. E I PXCAPPRV'=PXCAIEN D
... S PXCA("WARNING","PROVIDER",PXCAIEN,0,1)="There is already a Primary Provider this one is changed to Secondary^"_PXCAITEM
... S $P(PXCAPRV,"^",1)="S"
. S PXCAITEM=$P(PXCAPRV,"^",2)
. I '(PXCAITEM=1!(PXCAITEM=0)!(PXCAITEM="")) S PXCA("ERROR","PROVIDER",PXCAIEN,0,2)="Attending flag bad^"_PXCAITEM
. I PXCABULD&'$D(PXCA("ERROR","PROVIDER",PXCAIEN))!PXCAERRS D PRV(PXCAPRV,.PXCANPRV,PXCAIEN,PXCAERRS)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXCAPRV 4083 printed Dec 13, 2024@02:27:39 Page 2
PXCAPRV ;ISL/dee - Translates data from the PCE Device Interface into PCE's PXK for Providers ;3/14/97
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**27**;Aug 12, 1996
+2 QUIT
+3 ;
PROVIDER(PXCAENC) ;Provider
+1 ; Variables
+2 ; PXCAPRV Pointer to the provider (200)
+3 ; PXCAPS Primary or Secondary provider for above
+4 ; PXCAATND Pointer to the Attending provider (200)
+5 ; PXCAFTER Temp used to build ^TMP(PXCAGLB,$J,"PRV",PXCANPRV,0,"AFTER")
+6 NEW PXCAPRV,PXCAPS,PXCAATND,PXCAFTER
+7 SET PXCAPRV=$PIECE(PXCAENC,"^",4)
+8 SET PXCAPS=$PIECE(PXCAENC,"^",15)
+9 SET PXCAATND=$PIECE(PXCAENC,"^",16)
+10 IF PXCAPRV>0
Begin DoDot:1
+11 SET PXCAFTER=PXCAPRV_"^"
+12 SET PXCAFTER=PXCAFTER_PXCAPAT_"^"_PXCAVSIT_"^"
+13 SET PXCAFTER=PXCAFTER_PXCAPS_"^"
+14 IF PXCAATND>0
Begin DoDot:2
+15 IF PXCAATND=PXCAPRV
SET PXCAFTER=PXCAFTER_"A"
+16 IF '$TEST
DO ATTEND
End DoDot:2
+17 SET PXCANPRV=PXCANPRV+1
+18 SET ^TMP(PXCAGLB,$JOB,"PRV",PXCANPRV,"IEN")=""
+19 SET ^TMP(PXCAGLB,$JOB,"PRV",PXCANPRV,0,"BEFORE")=""
+20 SET ^TMP(PXCAGLB,$JOB,"PRV",PXCANPRV,0,"AFTER")=PXCAFTER
+21 SET ^TMP(PXCAGLB,$JOB,"PRV",PXCANPRV,812,"BEFORE")=""
+22 SET ^TMP(PXCAGLB,$JOB,"PRV",PXCANPRV,812,"AFTER")="^"_PXCAPKG_"^"_PXCASOR
End DoDot:1
+23 IF '$TEST
IF PXCAATND>0
DO ATTEND
+24 QUIT
+25 ;
ATTEND ;Add the attending provider.
+1 SET PXCANPRV=PXCANPRV+1
+2 SET ^TMP(PXCAGLB,$JOB,"PRV",PXCANPRV,"IEN")=""
+3 SET ^TMP(PXCAGLB,$JOB,"PRV",PXCANPRV,0,"BEFORE")=""
+4 SET ^TMP(PXCAGLB,$JOB,"PRV",PXCANPRV,0,"AFTER")=PXCAATND_"^"_PXCAPAT_"^"_PXCAVSIT_"^S^A"
+5 SET ^TMP(PXCAGLB,$JOB,"PRV",PXCANPRV,812,"BEFORE")=""
+6 SET ^TMP(PXCAGLB,$JOB,"PRV",PXCANPRV,812,"AFTER")="^"_PXCAPKG_"^"_PXCASOR
+7 QUIT
+8 ;
ANOTHPRV(PXCAAPRV) ;
+1 ;Add the provider to V Provider if they are not there.
+2 ;Quit if the provider subscript is zero
+3 ; Variables
+4 ; PXCAAPRV Pointer to the provider (200)
+5 ; PXCAINDX Subscirpt of the provider in the temp array used to
+6 ; look to see if the above provider is already know.
+7 if PXCAAPRV'>0
QUIT
+8 NEW PXCAINDX
+9 SET PXCAINDX=0
+10 FOR PXCAINDX=1:1:PXCANPRV
IF PXCAAPRV=+^TMP(PXCAGLB,$JOB,"PRV",PXCAINDX,0,"AFTER")
SET PXCAINDX=0
QUIT
+11 if PXCAINDX'>0
QUIT
+12 SET PXCANPRV=PXCANPRV+1
+13 SET ^TMP(PXCAGLB,$JOB,"PRV",PXCANPRV,"IEN")=""
+14 SET ^TMP(PXCAGLB,$JOB,"PRV",PXCANPRV,0,"BEFORE")=""
+15 SET ^TMP(PXCAGLB,$JOB,"PRV",PXCANPRV,0,"AFTER")=PXCAAPRV_"^"_PXCAPAT_"^"_PXCAVSIT_"^S"
+16 SET ^TMP(PXCAGLB,$JOB,"PRV",PXCANPRV,812,"BEFORE")=""
+17 SET ^TMP(PXCAGLB,$JOB,"PRV",PXCANPRV,812,"AFTER")="^"_PXCAPKG_"^"_PXCASOR
+18 QUIT
+19 ;
PRV(PXCAPRV,PXCANPRV,PXCAIEN,PXCAERRS) ;Process the provider nodes
+1 NEW PXCAINDX,PXCANEW
+2 SET PXCANEW=1
+3 FOR PXCAINDX=1:1:PXCANPRV
IF PXCAIEN=+^TMP(PXCAGLB,$JOB,"PRV",PXCAINDX,0,"AFTER")
SET PXCANEW=0
QUIT
+4 IF PXCANEW
Begin DoDot:1
+5 SET (PXCANPRV,PXCAINDX)=PXCANPRV+1
+6 SET ^TMP(PXCAGLB,$JOB,"PRV",PXCAINDX,"IEN")=""
+7 SET ^TMP(PXCAGLB,$JOB,"PRV",PXCAINDX,0,"BEFORE")=""
+8 SET ^TMP(PXCAGLB,$JOB,"PRV",PXCAINDX,0,"AFTER")=PXCAIEN_"^"_PXCAPAT_"^"_PXCAVSIT
+9 SET ^TMP(PXCAGLB,$JOB,"PRV",PXCAINDX,812,"BEFORE")=""
+10 SET ^TMP(PXCAGLB,$JOB,"PRV",PXCAINDX,812,"AFTER")="^"_PXCAPKG_"^"_PXCASOR
End DoDot:1
+11 SET $PIECE(^TMP(PXCAGLB,$JOB,"PRV",PXCAINDX,0,"AFTER"),"^",4)=$PIECE(PXCAPRV,"^",1)
+12 if $PIECE(PXCAPRV,"^",2)]""
SET $PIECE(^TMP(PXCAGLB,$JOB,"PRV",PXCAINDX,0,"AFTER"),"^",5)=$SELECT($PIECE(PXCAPRV,"^",2)=1:"A",1:"")
+13 QUIT
+14 ;
PROV(PXCA,PXCABULD,PXCAERRS) ;Validate the provider nodes
+1 if '$DATA(PXCA("PROVIDER"))
QUIT
+2 NEW PXCAIEN,PXCAPRV,PXCAITEM
+3 SET PXCAIEN=""
+4 FOR
SET PXCAIEN=$ORDER(PXCA("PROVIDER",PXCAIEN))
if PXCAIEN']""
QUIT
Begin DoDot:1
+5 IF '$$ACTIVPRV^PXAPI(PXCAIEN,PXCADT)
SET PXCA("ERROR","PROVIDER",PXCAIEN,0,0)="Provider is not active or valid^"_PXCAIEN
+6 SET PXCAPRV=$GET(PXCA("PROVIDER",PXCAIEN))
+7 SET PXCAITEM=$PIECE(PXCAPRV,"^",1)
+8 IF '(PXCAITEM="P"!(PXCAITEM="S"))
SET PXCA("ERROR","PROVIDER",PXCAIEN,0,1)="Provider indicator code must be P|S^"_PXCAITEM
+9 IF '$TEST
IF PXCAITEM="P"
Begin DoDot:2
+10 IF 'PXCAPPRV
SET PXCAPPRV=PXCAIEN
+11 IF '$TEST
IF PXCAPPRV'=PXCAIEN
Begin DoDot:3
+12 SET PXCA("WARNING","PROVIDER",PXCAIEN,0,1)="There is already a Primary Provider this one is changed to Secondary^"_PXCAITEM
+13 SET $PIECE(PXCAPRV,"^",1)="S"
End DoDot:3
End DoDot:2
+14 SET PXCAITEM=$PIECE(PXCAPRV,"^",2)
+15 IF '(PXCAITEM=1!(PXCAITEM=0)!(PXCAITEM=""))
SET PXCA("ERROR","PROVIDER",PXCAIEN,0,2)="Attending flag bad^"_PXCAITEM
+16 IF PXCABULD&'$DATA(PXCA("ERROR","PROVIDER",PXCAIEN))!PXCAERRS
DO PRV(PXCAPRV,.PXCANPRV,PXCAIEN,PXCAERRS)
End DoDot:1
+17 QUIT
+18 ;
