PXKENCOUNTER ;SLC/PKR - Builds an array of all encounter data. ;Aug 26, 2025@13:51:40
;;1.0;PCE PATIENT CARE ENCOUNTER;**217,244**;Aug 12, 1996;Build 37
Q
;
COEVENT(VISITIEN) ;Add to the ^TMP("PXKCO",$J, array the
;already exisiting encounter data. This is for the PXK VISIT
;DATA event.
I $G(VISITIEN)'>0 Q ;PX/183
I '$D(^AUPNVSIT(VISITIEN)) Q
N CSTPIEN,IND,MODIFIER,NODE,NUMM,NUMP,NUMS,PRV,PRVLIST,PS,TEMP,TMPSUB,VFIEN
S TMPSUB="PXKCO"
;Credit Stop Visits
S CSTPIEN=""
F S CSTPIEN=$O(^AUPNVSIT("AD",VISITIEN,CSTPIEN)) Q:CSTPIEN="" D
. I "SC"'[$P($G(^AUPNVSIT(CSTPIEN,150)),"^",3) Q
. S NODE=""
. F S NODE=$O(^AUPNVSIT(CSTPIEN,NODE)) Q:(NODE'=+NODE) D
.. I NODE=800!(NODE=900) D Q
... S OLD800="" K SAS
... D GETSAFORVISITDET^PXSPECAUTH(.SAS,.OLD800,CSTPIEN)
... M ^TMP(TMPSUB,$J,VISITIEN,"CSTP",CSTPIEN,900,"BEFORE")=SAS,^TMP(TMPSUB,$J,VISITIEN,"CSTP",CSTPIEN,900,"AFTER")=SAS
... I OLD800'="" S (^TMP(TMPSUB,$J,VISITIEN,"CSTP",CSTPIEN,800,"BEFORE"),^TMP(TMPSUB,$J,VISITIEN,"CSTP",CSTPIEN,800,"AFTER"))=OLD800
.. S ^TMP(TMPSUB,$J,VISITIEN,"CSTP",CSTPIEN,NODE,"AFTER")=^AUPNVSIT(CSTPIEN,NODE)
.. S ^TMP(TMPSUB,$J,VISITIEN,"CSTP",CSTPIEN,NODE,"BEFORE")=^AUPNVSIT(CSTPIEN,NODE)
;
;V CPT
S VFIEN=""
F S VFIEN=$O(^AUPNVCPT("AD",VISITIEN,VFIEN)) Q:VFIEN="" D
. S NODE=""
. F S NODE=$O(^AUPNVCPT(VFIEN,NODE)) Q:(NODE'=+NODE) D
.. I NODE=801 Q
..;Modifiers.
.. I NODE=1 D
... S IND=0
... F S IND=+$O(^AUPNVCPT(VFIEN,NODE,IND)) Q:IND=0 D
.... S MODIFIER=^AUPNVCPT(VFIEN,NODE,IND,0)
.... S ^TMP(TMPSUB,$J,VISITIEN,"CPT",VFIEN,NODE,"AFTER",MODIFIER)=""
.... S ^TMP(TMPSUB,$J,VISITIEN,"CPT",VFIEN,NODE,"BEFORE",MODIFIER)=""
.. E D
... S ^TMP(TMPSUB,$J,VISITIEN,"CPT",VFIEN,NODE,"AFTER")=^AUPNVCPT(VFIEN,NODE)
... S ^TMP(TMPSUB,$J,VISITIEN,"CPT",VFIEN,NODE,"BEFORE")=^AUPNVCPT(VFIEN,NODE)
;
;V EXAM
S VFIEN=""
F S VFIEN=$O(^AUPNVXAM("AD",VISITIEN,VFIEN)) Q:VFIEN="" D
. S NODE=""
. F S NODE=$O(^AUPNVXAM(VFIEN,NODE)) Q:(NODE'=+NODE) D
.. I NODE=801 Q
.. S ^TMP(TMPSUB,$J,VISITIEN,"XAM",VFIEN,NODE,"AFTER")=^AUPNVXAM(VFIEN,NODE)
.. S ^TMP(TMPSUB,$J,VISITIEN,"XAM",VFIEN,NODE,"BEFORE")=^AUPNVXAM(VFIEN,NODE)
;
;V HF
S VFIEN=""
F S VFIEN=$O(^AUPNVHF("AD",VISITIEN,VFIEN)) Q:VFIEN="" D
. S NODE=""
. F S NODE=$O(^AUPNVHF(VFIEN,NODE)) Q:(NODE'=+NODE) D
.. I NODE=801 Q
.. S ^TMP(TMPSUB,$J,VISITIEN,"HF",VFIEN,NODE,"AFTER")=^AUPNVHF(VFIEN,NODE)
.. S ^TMP(TMPSUB,$J,VISITIEN,"HF",VFIEN,NODE,"BEFORE")=^AUPNVHF(VFIEN,NODE)
;
;V ICR
S VFIEN=""
F S VFIEN=$O(^AUPNVICR("AD",VISITIEN,VFIEN)) Q:VFIEN="" D
. S NODE=""
. F S NODE=$O(^AUPNVICR(VFIEN,NODE)) Q:(NODE'=+NODE) D
.. I NODE=801 Q
.. S ^TMP(TMPSUB,$J,VISITIEN,"ICR",VFIEN,NODE,"AFTER")=^AUPNVICR(VFIEN,NODE)
.. S ^TMP(TMPSUB,$J,VISITIEN,"ICR",VFIEN,NODE,"BEFORE")=^AUPNVICR(VFIEN,NODE)
;
;V IMM
S VFIEN=""
F S VFIEN=$O(^AUPNVIMM("AD",VISITIEN,VFIEN)) Q:VFIEN="" D
. S NODE=""
. F S NODE=$O(^AUPNVIMM(VFIEN,NODE)) Q:(NODE'=+NODE) D
.. I NODE=801 Q
..;Fields that are multiples.
.. I (NODE=2)!(NODE=3)!(NODE=11) D
... S IND=0
... F S IND=+$O(^AUPNVIMM(VFIEN,NODE,IND)) Q:IND=0 D
.... S TEMP=^AUPNVIMM(VFIEN,NODE,IND,0)
.... S ^TMP(TMPSUB,$J,VISITIEN,"IMM",VFIEN,NODE,"AFTER",IND)=TEMP
.... S ^TMP(TMPSUB,$J,VISITIEN,"IMM",VFIEN,NODE,"BEFORE",IND)=TEMP
.. E D
... S ^TMP(TMPSUB,$J,VISITIEN,"IMM",VFIEN,NODE,"AFTER")=^AUPNVIMM(VFIEN,NODE)
... S ^TMP(TMPSUB,$J,VISITIEN,"IMM",VFIEN,NODE,"BEFORE")=^AUPNVIMM(VFIEN,NODE)
;
;V PED
S VFIEN=""
F S VFIEN=$O(^AUPNVPED("AD",VISITIEN,VFIEN)) Q:VFIEN="" D
. S NODE=""
. F S NODE=$O(^AUPNVPED(VFIEN,NODE)) Q:(NODE'=+NODE) D
.. I NODE=801 Q
.. S ^TMP(TMPSUB,$J,VISITIEN,"PED",VFIEN,NODE,"AFTER")=^AUPNVPED(VFIEN,NODE)
.. S ^TMP(TMPSUB,$J,VISITIEN,"PED",VFIEN,NODE,"BEFORE")=^AUPNVPED(VFIEN,NODE)
;
;V POV
S VFIEN=""
F S VFIEN=$O(^AUPNVPOV("AD",VISITIEN,VFIEN)) Q:VFIEN="" D
. S NODE=""
. F S NODE=$O(^AUPNVPOV(VFIEN,NODE)) Q:(NODE'=+NODE) D
.. I NODE=801 Q
.. I NODE=800!(NODE=900) D Q
... S OLD800=""
... D GETSAFORVPOVDET^PXSPECAUTH(.SAS,.OLD800,VFIEN)
... M ^TMP(TMPSUB,$J,VISITIEN,"POV",VFIEN,900,"AFTER")=SAS
... M ^TMP(TMPSUB,$J,VISITIEN,"POV",VFIEN,900,"BEFORE")=SAS
... I OLD800'="" D
.... S ^TMP(TMPSUB,$J,VISITIEN,"POV",VFIEN,800,"AFTER")=OLD800
.... S ^TMP(TMPSUB,$J,VISITIEN,"POV",VFIEN,800,"BEFORE")=OLD800
.. S ^TMP(TMPSUB,$J,VISITIEN,"POV",VFIEN,NODE,"AFTER")=^AUPNVPOV(VFIEN,NODE)
.. S ^TMP(TMPSUB,$J,VISITIEN,"POV",VFIEN,NODE,"BEFORE")=^AUPNVPOV(VFIEN,NODE)
;
;V PROVIDER
S VFIEN=""
F S VFIEN=$O(^AUPNVPRV("AD",VISITIEN,VFIEN)) Q:VFIEN="" D
. S NODE=""
. F S NODE=$O(^AUPNVPRV(VFIEN,NODE)) Q:(NODE'=+NODE) D
.. I NODE=801 Q
.. I NODE=0 D
... S TEMP=^AUPNVPRV(VFIEN,NODE),PRV=$P(TEMP,U,1),PS=$P(TEMP,U,4)
...;Primary/Secondary is a required field but it is possible for it
...;to be missing.
... I PS="" S PS="M"
... S PRVLIST(PRV,"CNT")=$G(PRVLIST(PRV,"CNT"))+1
... S PRVLIST(PRV,PS,"CNT")=$G(PRVLIST(PRV,PS,"CNT"))+1
... S PRVLIST(PRV,PS,PRVLIST(PRV,"CNT"))=VFIEN
.. S ^TMP(TMPSUB,$J,VISITIEN,"PRV",VFIEN,NODE,"AFTER")=^AUPNVPRV(VFIEN,NODE)
.. S ^TMP(TMPSUB,$J,VISITIEN,"PRV",VFIEN,NODE,"BEFORE")=^AUPNVPRV(VFIEN,NODE)
;Remove duplicates.
S PRV=""
F S PRV=$O(PRVLIST(PRV)) Q:PRV="" D
. I PRVLIST(PRV,"CNT")=1 Q
. S NUMM=+$G(PRVLIST(PRV,"M","CNT"))
. S NUMP=+$G(PRVLIST(PRV,"P","CNT"))
. S NUMS=+$G(PRVLIST(PRV,"S","CNT"))
.;Remove any entries that are missing the Primary/Secondary designation.
. I NUMM>0 F IND=1:1:NUMM S VFIEN=PRVLIST(PRV,"M",IND) K ^TMP(TMPSUB,$J,VISITIEN,"PRV",VFIEN)
.;If this provider is listed as primary more than once, delete the other primaries.
. I NUMP>1 D
.. F IND=2:1:NUMP S VFIEN=PRVLIST(PRV,"P",IND) K ^TMP(TMPSUB,$J,VISITIEN,"PRV",VFIEN)
..;If this provider is a primary, delete all its secondaries and missing.
. I NUMP>0 D
.. F IND=1:1:NUMS S VFIEN=PRVLIST(PRV,"S",IND) K ^TMP(TMPSUB,$J,VISITIEN,"PRV",VFIEN)
.. S NUMS=0
.;If this provider is not primary, only keep the first secondary.
. I NUMS>1 D
.. F IND=2:1:NUMS D
... S VFIEN=PRVLIST(PRV,"S",IND)
... K ^TMP(TMPSUB,$J,VISITIEN,"PRV",VFIEN)
;
;V SC
S VFIEN=""
F S VFIEN=$O(^AUPNVSC("AD",VISITIEN,VFIEN)) Q:VFIEN="" D
. S NODE=""
. F S NODE=$O(^AUPNVSC(VFIEN,NODE)) Q:(NODE'=+NODE) D
.. I NODE=801 Q
.. S ^TMP(TMPSUB,$J,VISITIEN,"SC",VFIEN,NODE,"AFTER")=^AUPNVSC(VFIEN,NODE)
.. S ^TMP(TMPSUB,$J,VISITIEN,"SC",VFIEN,NODE,"BEFORE")=^AUPNVSC(VFIEN,NODE)
;
;V SKIN
S VFIEN=""
F S VFIEN=$O(^AUPNVSK("AD",VISITIEN,VFIEN)) Q:VFIEN="" D
. S NODE=""
. F S NODE=$O(^AUPNVSK(VFIEN,NODE)) Q:(NODE'=+NODE) D
.. I NODE=801 Q
.. S ^TMP(TMPSUB,$J,VISITIEN,"SK",VFIEN,NODE,"AFTER")=^AUPNVSK(VFIEN,NODE)
.. S ^TMP(TMPSUB,$J,VISITIEN,"SK",VFIEN,NODE,"BEFORE")=^AUPNVSK(VFIEN,NODE)
;
;V TRT
S VFIEN=""
F S VFIEN=$O(^AUPNVTRT("AD",VISITIEN,VFIEN)) Q:VFIEN="" D
. S NODE=""
. F S NODE=$O(^AUPNVTRT(VFIEN,NODE)) Q:(NODE'=+NODE) D
.. I NODE=801 Q
.. S ^TMP(TMPSUB,$J,VISITIEN,"TRT",VFIEN,NODE,"AFTER")=^AUPNVTRT(VFIEN,NODE)
.. S ^TMP(TMPSUB,$J,VISITIEN,"TRT",VFIEN,NODE,"BEFORE")=^AUPNVTRT(VFIEN,NODE)
Q
;
ENCEVENT(VISITIEN,DONTKILL) ;Create the ^TMP("PKRENC",$J, array of all the
;information about one encounter.
;Parameters:
; VISITIEN Pointer to the Visit (#9000010)
; DONOTKILL is 1 if the output array is not to be killed before used
; and 0 or null if the array is to be killed (cleaned out)
;
; The encounter is returned in the array
; ^TMP("PXKENC",$J,pointer to visit)
;
I $G(VISITIEN)'>0 Q ;PX/183
I '$D(^AUPNVSIT(VISITIEN)) Q
N CSTPIEN,ID,IND,NODE,NUMM,NUMP,NUMS,OLD800,PRV,PRVLIST,PS,TEMP,TMPSUB,SAS,VFIEN
S TMPSUB="PXKENC"
K:'$G(DONTKILL) ^TMP(TMPSUB,$J)
;Visit and Credit Stop Visits
S NODE=""
F S NODE=$O(^AUPNVSIT(VISITIEN,NODE)) Q:(NODE'=+NODE) D
. I NODE=800!(NODE=900) D Q
.. S OLD800=""
.. D GETSAFORVISITDET^PXSPECAUTH(.SAS,.OLD800,VISITIEN)
.. M ^TMP(TMPSUB,$J,VISITIEN,"VST",VISITIEN,900)=SAS
.. I OLD800'="" S ^TMP(TMPSUB,$J,VISITIEN,"VST",VISITIEN,800)=OLD800
. S ^TMP(TMPSUB,$J,VISITIEN,"VST",VISITIEN,NODE)=^AUPNVSIT(VISITIEN,NODE)
S CSTPIEN=""
F S CSTPIEN=$O(^AUPNVSIT("AD",VISITIEN,CSTPIEN)) Q:CSTPIEN="" D
. I "SC"'[$P($G(^AUPNVSIT(CSTPIEN,150)),"^",3) Q
. S NODE=""
. F S NODE=$O(^AUPNVSIT(CSTPIEN,NODE)) Q:(NODE'=+NODE) D
.. I NODE=800!(NODE=900) D Q
... S OLD800="" K SAS
... D GETSAFORVISITDET^PXSPECAUTH(.SAS,.OLD800,CSTPIEN)
... M ^TMP(TMPSUB,$J,VISITIEN,"CSTP",CSTPIEN,900)=SAS
... I OLD800'="" S ^TMP(TMPSUB,$J,VISITIEN,"CSTP",CSTPIEN,800)=OLD800
.. S ^TMP(TMPSUB,$J,VISITIEN,"CSTP",CSTPIEN,NODE)=^AUPNVSIT(CSTPIEN,NODE)
;
;V CPT
S VFIEN=""
F S VFIEN=$O(^AUPNVCPT("AD",VISITIEN,VFIEN)) Q:VFIEN="" D
. S NODE=""
. F S NODE=$O(^AUPNVCPT(VFIEN,NODE)) Q:(NODE'=+NODE) D
.. I NODE=801 Q
..;Modifiers.
.. I NODE=1 D
... S ^TMP(TMPSUB,$J,VISITIEN,"CPT",VFIEN,NODE,0)=^AUPNVCPT(VFIEN,NODE,0)
... S IND=0
... F S IND=+$O(^AUPNVCPT(VFIEN,NODE,IND)) Q:IND=0 D
.... S ^TMP(TMPSUB,$J,VISITIEN,"CPT",VFIEN,NODE,IND,0)=^AUPNVCPT(VFIEN,NODE,IND,0)
.. E S ^TMP(TMPSUB,$J,VISITIEN,"CPT",VFIEN,NODE)=^AUPNVCPT(VFIEN,NODE)
;
;V EXAM
S VFIEN=""
F S VFIEN=$O(^AUPNVXAM("AD",VISITIEN,VFIEN)) Q:VFIEN="" D
. S NODE=""
. F S NODE=$O(^AUPNVXAM(VFIEN,NODE)) Q:(NODE'=+NODE) D
.. I NODE=801 Q
.. S ^TMP(TMPSUB,$J,VISITIEN,"XAM",VFIEN,NODE)=^AUPNVXAM(VFIEN,NODE)
;
;V HF
S VFIEN=""
F S VFIEN=$O(^AUPNVHF("AD",VISITIEN,VFIEN)) Q:VFIEN="" D
. S NODE=""
. F S NODE=$O(^AUPNVHF(VFIEN,NODE)) Q:(NODE'=+NODE) D
.. I NODE=801 Q
.. S ^TMP(TMPSUB,$J,VISITIEN,"HF",VFIEN,NODE)=^AUPNVHF(VFIEN,NODE)
;
;V ICR
S VFIEN=""
F S VFIEN=$O(^AUPNVICR("AD",VISITIEN,VFIEN)) Q:VFIEN="" D
. S NODE=""
. F S NODE=$O(^AUPNVICR(VFIEN,NODE)) Q:(NODE'=+NODE) D
.. I NODE=801 Q
.. S ^TMP(TMPSUB,$J,VISITIEN,"ICR",VFIEN,NODE)=^AUPNVICR(VFIEN,NODE)
;
;V IMM
S VFIEN=""
F S VFIEN=$O(^AUPNVIMM("AD",VISITIEN,VFIEN)) Q:VFIEN="" D
. S NODE=""
. F S NODE=$O(^AUPNVIMM(VFIEN,NODE)) Q:(NODE'=+NODE) D
.. I NODE=801 Q
..;Fields that are multiples.
.. I (NODE=2)!(NODE=3)!(NODE=11) D
... S ^TMP(TMPSUB,$J,VISITIEN,"IMM",VFIEN,NODE,0)=^AUPNVIMM(VFIEN,NODE,0)
... S IND=0
... F S IND=+$O(^AUPNVIMM(VFIEN,NODE,IND)) Q:IND=0 D
.... S ^TMP(TMPSUB,$J,VISITIEN,"IMM",VFIEN,NODE,IND,0)=^AUPNVIMM(VFIEN,NODE,IND,0)
.. E S ^TMP(TMPSUB,$J,VISITIEN,"IMM",VFIEN,NODE)=^AUPNVIMM(VFIEN,NODE)
;
;V PED
S VFIEN=""
F S VFIEN=$O(^AUPNVPED("AD",VISITIEN,VFIEN)) Q:VFIEN="" D
. S NODE=""
. F S NODE=$O(^AUPNVPED(VFIEN,NODE)) Q:(NODE'=+NODE) D
.. I NODE=801 Q
.. S ^TMP(TMPSUB,$J,VISITIEN,"PED",VFIEN,NODE)=^AUPNVPED(VFIEN,NODE)
;
;V POV
S VFIEN=""
F S VFIEN=$O(^AUPNVPOV("AD",VISITIEN,VFIEN)) Q:VFIEN="" D
. S NODE=""
. F S NODE=$O(^AUPNVPOV(VFIEN,NODE)) Q:(NODE'=+NODE) D
.. I NODE=801 Q
.. I NODE=800!(NODE=900) D Q
... S OLD800=""
... D GETSAFORVPOVDET^PXSPECAUTH(.SAS,.OLD800,VFIEN)
... M ^TMP(TMPSUB,$J,VISITIEN,"POV",VFIEN,900)=SAS
... I OLD800'="" S ^TMP(TMPSUB,$J,VISITIEN,"POV",VFIEN,800)=OLD800
.. S ^TMP(TMPSUB,$J,VISITIEN,"POV",VFIEN,NODE)=^AUPNVPOV(VFIEN,NODE)
..;Check for bad Provider Narrative Category pointer.
.. I (NODE=802),(^AUPNVPOV(VFIEN,NODE)'>0) S ^TMP(TMPSUB,$J,VISITIEN,"POV",VFIEN,NODE)=""
;
;V PROVIDER
S VFIEN=""
F S VFIEN=$O(^AUPNVPRV("AD",VISITIEN,VFIEN)) Q:VFIEN="" D
. S NODE=""
. F S NODE=$O(^AUPNVPRV(VFIEN,NODE)) Q:(NODE'=+NODE) D
.. I NODE=801 Q
.. S ^TMP(TMPSUB,$J,VISITIEN,"PRV",VFIEN,NODE)=^AUPNVPRV(VFIEN,NODE)
.. I NODE=0 D
... S TEMP=^AUPNVPRV(VFIEN,NODE),PRV=$P(TEMP,U,1),PS=$P(TEMP,U,4)
...;Primary/Secondary is a required field but it is possible for it
...;to be missing.
... I PS="" S PS="M"
... S PRVLIST(PRV,"CNT")=$G(PRVLIST(PRV,"CNT"))+1
... S PRVLIST(PRV,PS,"CNT")=$G(PRVLIST(PRV,PS,"CNT"))+1
... S PRVLIST(PRV,PS,PRVLIST(PRV,PS,"CNT"))=VFIEN
;Remove duplicates.
S PRV=""
F S PRV=$O(PRVLIST(PRV)) Q:PRV="" D
. I PRVLIST(PRV,"CNT")=1 Q
. S NUMM=+$G(PRVLIST(PRV,"M","CNT"))
. S NUMP=+$G(PRVLIST(PRV,"P","CNT"))
. S NUMS=+$G(PRVLIST(PRV,"S","CNT"))
.;Remove any entries that are missing the Primary/Secondary designation.
. I NUMM>0 F IND=1:1:NUMM S VFIEN=PRVLIST(PRV,"M",IND) K ^TMP(TMPSUB,$J,VISITIEN,"PRV",VFIEN)
.;If this provider is listed as primary more than once, delete the other primaries.
. I NUMP>1 D
.. F IND=2:1:NUMP S VFIEN=PRVLIST(PRV,"P",IND) K ^TMP(TMPSUB,$J,VISITIEN,"PRV",VFIEN)
..;If this provider is a primary, delete all its secondaries and missing.
. I NUMP>0 D
.. F IND=1:1:NUMS S VFIEN=PRVLIST(PRV,"S",IND) K ^TMP(TMPSUB,$J,VISITIEN,"PRV",VFIEN)
.. S NUMS=0
.;If this provider is not primary, only keep the first secondary.
. I NUMS>1 D
.. F IND=2:1:NUMS D
... S VFIEN=PRVLIST(PRV,"S",IND)
... K ^TMP(TMPSUB,$J,VISITIEN,"PRV",VFIEN)
;
;V SC
S VFIEN=""
F S VFIEN=$O(^AUPNVSC("AD",VISITIEN,VFIEN)) Q:VFIEN="" D
. S NODE=""
. F S NODE=$O(^AUPNVSC(VFIEN,NODE)) Q:(NODE'=+NODE) D
.. I NODE=801 Q
.. S ^TMP(TMPSUB,$J,VISITIEN,"SC",VFIEN,NODE)=^AUPNVSC(VFIEN,NODE)
;
;V SKIN
S VFIEN=""
F S VFIEN=$O(^AUPNVSK("AD",VISITIEN,VFIEN)) Q:VFIEN="" D
. S NODE=""
. F S NODE=$O(^AUPNVSK(VFIEN,NODE)) Q:(NODE'=+NODE) D
.. I NODE=801 Q
.. S ^TMP(TMPSUB,$J,VISITIEN,"SK",VFIEN,NODE)=^AUPNVSK(VFIEN,NODE)
;
;V TRT
S VFIEN=""
F S VFIEN=$O(^AUPNVTRT("AD",VISITIEN,VFIEN)) Q:VFIEN="" D
. S NODE=""
. F S NODE=$O(^AUPNVTRT(VFIEN,NODE)) Q:(NODE'=+NODE) D
.. I NODE=801 Q
.. S ^TMP(TMPSUB,$J,VISITIEN,"TRT",VFIEN,NODE)=^AUPNVTRT(VFIEN,NODE)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXKENCOUNTER 13835 printed Jul 11, 2026@02:25:32 Page 2
PXKENCOUNTER ;SLC/PKR - Builds an array of all encounter data. ;Aug 26, 2025@13:51:40
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**217,244**;Aug 12, 1996;Build 37
+2 QUIT
+3 ;
COEVENT(VISITIEN) ;Add to the ^TMP("PXKCO",$J, array the
+1 ;already exisiting encounter data. This is for the PXK VISIT
+2 ;DATA event.
+3 ;PX/183
IF $GET(VISITIEN)'>0
QUIT
+4 IF '$DATA(^AUPNVSIT(VISITIEN))
QUIT
+5 NEW CSTPIEN,IND,MODIFIER,NODE,NUMM,NUMP,NUMS,PRV,PRVLIST,PS,TEMP,TMPSUB,VFIEN
+6 SET TMPSUB="PXKCO"
+7 ;Credit Stop Visits
+8 SET CSTPIEN=""
+9 FOR
SET CSTPIEN=$ORDER(^AUPNVSIT("AD",VISITIEN,CSTPIEN))
if CSTPIEN=""
QUIT
Begin DoDot:1
+10 IF "SC"'[$PIECE($GET(^AUPNVSIT(CSTPIEN,150)),"^",3)
QUIT
+11 SET NODE=""
+12 FOR
SET NODE=$ORDER(^AUPNVSIT(CSTPIEN,NODE))
if (NODE'=+NODE)
QUIT
Begin DoDot:2
+13 IF NODE=800!(NODE=900)
Begin DoDot:3
+14 SET OLD800=""
KILL SAS
+15 DO GETSAFORVISITDET^PXSPECAUTH(.SAS,.OLD800,CSTPIEN)
+16 MERGE ^TMP(TMPSUB,$JOB,VISITIEN,"CSTP",CSTPIEN,900,"BEFORE")=SAS,^TMP(TMPSUB,$JOB,VISITIEN,"CSTP",CSTPIEN,900,"AFTER")=SAS
+17 IF OLD800'=""
SET (^TMP(TMPSUB,$JOB,VISITIEN,"CSTP",CSTPIEN,800,"BEFORE"),^TMP(TMPSUB,$JOB,VISITIEN,"CSTP",CSTPIEN,800,"AFTER"))=OLD800
End DoDot:3
QUIT
+18 SET ^TMP(TMPSUB,$JOB,VISITIEN,"CSTP",CSTPIEN,NODE,"AFTER")=^AUPNVSIT(CSTPIEN,NODE)
+19 SET ^TMP(TMPSUB,$JOB,VISITIEN,"CSTP",CSTPIEN,NODE,"BEFORE")=^AUPNVSIT(CSTPIEN,NODE)
End DoDot:2
End DoDot:1
+20 ;
+21 ;V CPT
+22 SET VFIEN=""
+23 FOR
SET VFIEN=$ORDER(^AUPNVCPT("AD",VISITIEN,VFIEN))
if VFIEN=""
QUIT
Begin DoDot:1
+24 SET NODE=""
+25 FOR
SET NODE=$ORDER(^AUPNVCPT(VFIEN,NODE))
if (NODE'=+NODE)
QUIT
Begin DoDot:2
+26 IF NODE=801
QUIT
+27 ;Modifiers.
+28 IF NODE=1
Begin DoDot:3
+29 SET IND=0
+30 FOR
SET IND=+$ORDER(^AUPNVCPT(VFIEN,NODE,IND))
if IND=0
QUIT
Begin DoDot:4
+31 SET MODIFIER=^AUPNVCPT(VFIEN,NODE,IND,0)
+32 SET ^TMP(TMPSUB,$JOB,VISITIEN,"CPT",VFIEN,NODE,"AFTER",MODIFIER)=""
+33 SET ^TMP(TMPSUB,$JOB,VISITIEN,"CPT",VFIEN,NODE,"BEFORE",MODIFIER)=""
End DoDot:4
End DoDot:3
+34 IF '$TEST
Begin DoDot:3
+35 SET ^TMP(TMPSUB,$JOB,VISITIEN,"CPT",VFIEN,NODE,"AFTER")=^AUPNVCPT(VFIEN,NODE)
+36 SET ^TMP(TMPSUB,$JOB,VISITIEN,"CPT",VFIEN,NODE,"BEFORE")=^AUPNVCPT(VFIEN,NODE)
End DoDot:3
End DoDot:2
End DoDot:1
+37 ;
+38 ;V EXAM
+39 SET VFIEN=""
+40 FOR
SET VFIEN=$ORDER(^AUPNVXAM("AD",VISITIEN,VFIEN))
if VFIEN=""
QUIT
Begin DoDot:1
+41 SET NODE=""
+42 FOR
SET NODE=$ORDER(^AUPNVXAM(VFIEN,NODE))
if (NODE'=+NODE)
QUIT
Begin DoDot:2
+43 IF NODE=801
QUIT
+44 SET ^TMP(TMPSUB,$JOB,VISITIEN,"XAM",VFIEN,NODE,"AFTER")=^AUPNVXAM(VFIEN,NODE)
+45 SET ^TMP(TMPSUB,$JOB,VISITIEN,"XAM",VFIEN,NODE,"BEFORE")=^AUPNVXAM(VFIEN,NODE)
End DoDot:2
End DoDot:1
+46 ;
+47 ;V HF
+48 SET VFIEN=""
+49 FOR
SET VFIEN=$ORDER(^AUPNVHF("AD",VISITIEN,VFIEN))
if VFIEN=""
QUIT
Begin DoDot:1
+50 SET NODE=""
+51 FOR
SET NODE=$ORDER(^AUPNVHF(VFIEN,NODE))
if (NODE'=+NODE)
QUIT
Begin DoDot:2
+52 IF NODE=801
QUIT
+53 SET ^TMP(TMPSUB,$JOB,VISITIEN,"HF",VFIEN,NODE,"AFTER")=^AUPNVHF(VFIEN,NODE)
+54 SET ^TMP(TMPSUB,$JOB,VISITIEN,"HF",VFIEN,NODE,"BEFORE")=^AUPNVHF(VFIEN,NODE)
End DoDot:2
End DoDot:1
+55 ;
+56 ;V ICR
+57 SET VFIEN=""
+58 FOR
SET VFIEN=$ORDER(^AUPNVICR("AD",VISITIEN,VFIEN))
if VFIEN=""
QUIT
Begin DoDot:1
+59 SET NODE=""
+60 FOR
SET NODE=$ORDER(^AUPNVICR(VFIEN,NODE))
if (NODE'=+NODE)
QUIT
Begin DoDot:2
+61 IF NODE=801
QUIT
+62 SET ^TMP(TMPSUB,$JOB,VISITIEN,"ICR",VFIEN,NODE,"AFTER")=^AUPNVICR(VFIEN,NODE)
+63 SET ^TMP(TMPSUB,$JOB,VISITIEN,"ICR",VFIEN,NODE,"BEFORE")=^AUPNVICR(VFIEN,NODE)
End DoDot:2
End DoDot:1
+64 ;
+65 ;V IMM
+66 SET VFIEN=""
+67 FOR
SET VFIEN=$ORDER(^AUPNVIMM("AD",VISITIEN,VFIEN))
if VFIEN=""
QUIT
Begin DoDot:1
+68 SET NODE=""
+69 FOR
SET NODE=$ORDER(^AUPNVIMM(VFIEN,NODE))
if (NODE'=+NODE)
QUIT
Begin DoDot:2
+70 IF NODE=801
QUIT
+71 ;Fields that are multiples.
+72 IF (NODE=2)!(NODE=3)!(NODE=11)
Begin DoDot:3
+73 SET IND=0
+74 FOR
SET IND=+$ORDER(^AUPNVIMM(VFIEN,NODE,IND))
if IND=0
QUIT
Begin DoDot:4
+75 SET TEMP=^AUPNVIMM(VFIEN,NODE,IND,0)
+76 SET ^TMP(TMPSUB,$JOB,VISITIEN,"IMM",VFIEN,NODE,"AFTER",IND)=TEMP
+77 SET ^TMP(TMPSUB,$JOB,VISITIEN,"IMM",VFIEN,NODE,"BEFORE",IND)=TEMP
End DoDot:4
End DoDot:3
+78 IF '$TEST
Begin DoDot:3
+79 SET ^TMP(TMPSUB,$JOB,VISITIEN,"IMM",VFIEN,NODE,"AFTER")=^AUPNVIMM(VFIEN,NODE)
+80 SET ^TMP(TMPSUB,$JOB,VISITIEN,"IMM",VFIEN,NODE,"BEFORE")=^AUPNVIMM(VFIEN,NODE)
End DoDot:3
End DoDot:2
End DoDot:1
+81 ;
+82 ;V PED
+83 SET VFIEN=""
+84 FOR
SET VFIEN=$ORDER(^AUPNVPED("AD",VISITIEN,VFIEN))
if VFIEN=""
QUIT
Begin DoDot:1
+85 SET NODE=""
+86 FOR
SET NODE=$ORDER(^AUPNVPED(VFIEN,NODE))
if (NODE'=+NODE)
QUIT
Begin DoDot:2
+87 IF NODE=801
QUIT
+88 SET ^TMP(TMPSUB,$JOB,VISITIEN,"PED",VFIEN,NODE,"AFTER")=^AUPNVPED(VFIEN,NODE)
+89 SET ^TMP(TMPSUB,$JOB,VISITIEN,"PED",VFIEN,NODE,"BEFORE")=^AUPNVPED(VFIEN,NODE)
End DoDot:2
End DoDot:1
+90 ;
+91 ;V POV
+92 SET VFIEN=""
+93 FOR
SET VFIEN=$ORDER(^AUPNVPOV("AD",VISITIEN,VFIEN))
if VFIEN=""
QUIT
Begin DoDot:1
+94 SET NODE=""
+95 FOR
SET NODE=$ORDER(^AUPNVPOV(VFIEN,NODE))
if (NODE'=+NODE)
QUIT
Begin DoDot:2
+96 IF NODE=801
QUIT
+97 IF NODE=800!(NODE=900)
Begin DoDot:3
+98 SET OLD800=""
+99 DO GETSAFORVPOVDET^PXSPECAUTH(.SAS,.OLD800,VFIEN)
+100 MERGE ^TMP(TMPSUB,$JOB,VISITIEN,"POV",VFIEN,900,"AFTER")=SAS
+101 MERGE ^TMP(TMPSUB,$JOB,VISITIEN,"POV",VFIEN,900,"BEFORE")=SAS
+102 IF OLD800'=""
Begin DoDot:4
+103 SET ^TMP(TMPSUB,$JOB,VISITIEN,"POV",VFIEN,800,"AFTER")=OLD800
+104 SET ^TMP(TMPSUB,$JOB,VISITIEN,"POV",VFIEN,800,"BEFORE")=OLD800
End DoDot:4
End DoDot:3
QUIT
+105 SET ^TMP(TMPSUB,$JOB,VISITIEN,"POV",VFIEN,NODE,"AFTER")=^AUPNVPOV(VFIEN,NODE)
+106 SET ^TMP(TMPSUB,$JOB,VISITIEN,"POV",VFIEN,NODE,"BEFORE")=^AUPNVPOV(VFIEN,NODE)
End DoDot:2
End DoDot:1
+107 ;
+108 ;V PROVIDER
+109 SET VFIEN=""
+110 FOR
SET VFIEN=$ORDER(^AUPNVPRV("AD",VISITIEN,VFIEN))
if VFIEN=""
QUIT
Begin DoDot:1
+111 SET NODE=""
+112 FOR
SET NODE=$ORDER(^AUPNVPRV(VFIEN,NODE))
if (NODE'=+NODE)
QUIT
Begin DoDot:2
+113 IF NODE=801
QUIT
+114 IF NODE=0
Begin DoDot:3
+115 SET TEMP=^AUPNVPRV(VFIEN,NODE)
SET PRV=$PIECE(TEMP,U,1)
SET PS=$PIECE(TEMP,U,4)
+116 ;Primary/Secondary is a required field but it is possible for it
+117 ;to be missing.
+118 IF PS=""
SET PS="M"
+119 SET PRVLIST(PRV,"CNT")=$GET(PRVLIST(PRV,"CNT"))+1
+120 SET PRVLIST(PRV,PS,"CNT")=$GET(PRVLIST(PRV,PS,"CNT"))+1
+121 SET PRVLIST(PRV,PS,PRVLIST(PRV,"CNT"))=VFIEN
End DoDot:3
+122 SET ^TMP(TMPSUB,$JOB,VISITIEN,"PRV",VFIEN,NODE,"AFTER")=^AUPNVPRV(VFIEN,NODE)
+123 SET ^TMP(TMPSUB,$JOB,VISITIEN,"PRV",VFIEN,NODE,"BEFORE")=^AUPNVPRV(VFIEN,NODE)
End DoDot:2
End DoDot:1
+124 ;Remove duplicates.
+125 SET PRV=""
+126 FOR
SET PRV=$ORDER(PRVLIST(PRV))
if PRV=""
QUIT
Begin DoDot:1
+127 IF PRVLIST(PRV,"CNT")=1
QUIT
+128 SET NUMM=+$GET(PRVLIST(PRV,"M","CNT"))
+129 SET NUMP=+$GET(PRVLIST(PRV,"P","CNT"))
+130 SET NUMS=+$GET(PRVLIST(PRV,"S","CNT"))
+131 ;Remove any entries that are missing the Primary/Secondary designation.
+132 IF NUMM>0
FOR IND=1:1:NUMM
SET VFIEN=PRVLIST(PRV,"M",IND)
KILL ^TMP(TMPSUB,$JOB,VISITIEN,"PRV",VFIEN)
+133 ;If this provider is listed as primary more than once, delete the other primaries.
+134 IF NUMP>1
Begin DoDot:2
+135 FOR IND=2:1:NUMP
SET VFIEN=PRVLIST(PRV,"P",IND)
KILL ^TMP(TMPSUB,$JOB,VISITIEN,"PRV",VFIEN)
+136 ;If this provider is a primary, delete all its secondaries and missing.
End DoDot:2
+137 IF NUMP>0
Begin DoDot:2
+138 FOR IND=1:1:NUMS
SET VFIEN=PRVLIST(PRV,"S",IND)
KILL ^TMP(TMPSUB,$JOB,VISITIEN,"PRV",VFIEN)
+139 SET NUMS=0
End DoDot:2
+140 ;If this provider is not primary, only keep the first secondary.
+141 IF NUMS>1
Begin DoDot:2
+142 FOR IND=2:1:NUMS
Begin DoDot:3
+143 SET VFIEN=PRVLIST(PRV,"S",IND)
+144 KILL ^TMP(TMPSUB,$JOB,VISITIEN,"PRV",VFIEN)
End DoDot:3
End DoDot:2
End DoDot:1
+145 ;
+146 ;V SC
+147 SET VFIEN=""
+148 FOR
SET VFIEN=$ORDER(^AUPNVSC("AD",VISITIEN,VFIEN))
if VFIEN=""
QUIT
Begin DoDot:1
+149 SET NODE=""
+150 FOR
SET NODE=$ORDER(^AUPNVSC(VFIEN,NODE))
if (NODE'=+NODE)
QUIT
Begin DoDot:2
+151 IF NODE=801
QUIT
+152 SET ^TMP(TMPSUB,$JOB,VISITIEN,"SC",VFIEN,NODE,"AFTER")=^AUPNVSC(VFIEN,NODE)
+153 SET ^TMP(TMPSUB,$JOB,VISITIEN,"SC",VFIEN,NODE,"BEFORE")=^AUPNVSC(VFIEN,NODE)
End DoDot:2
End DoDot:1
+154 ;
+155 ;V SKIN
+156 SET VFIEN=""
+157 FOR
SET VFIEN=$ORDER(^AUPNVSK("AD",VISITIEN,VFIEN))
if VFIEN=""
QUIT
Begin DoDot:1
+158 SET NODE=""
+159 FOR
SET NODE=$ORDER(^AUPNVSK(VFIEN,NODE))
if (NODE'=+NODE)
QUIT
Begin DoDot:2
+160 IF NODE=801
QUIT
+161 SET ^TMP(TMPSUB,$JOB,VISITIEN,"SK",VFIEN,NODE,"AFTER")=^AUPNVSK(VFIEN,NODE)
+162 SET ^TMP(TMPSUB,$JOB,VISITIEN,"SK",VFIEN,NODE,"BEFORE")=^AUPNVSK(VFIEN,NODE)
End DoDot:2
End DoDot:1
+163 ;
+164 ;V TRT
+165 SET VFIEN=""
+166 FOR
SET VFIEN=$ORDER(^AUPNVTRT("AD",VISITIEN,VFIEN))
if VFIEN=""
QUIT
Begin DoDot:1
+167 SET NODE=""
+168 FOR
SET NODE=$ORDER(^AUPNVTRT(VFIEN,NODE))
if (NODE'=+NODE)
QUIT
Begin DoDot:2
+169 IF NODE=801
QUIT
+170 SET ^TMP(TMPSUB,$JOB,VISITIEN,"TRT",VFIEN,NODE,"AFTER")=^AUPNVTRT(VFIEN,NODE)
+171 SET ^TMP(TMPSUB,$JOB,VISITIEN,"TRT",VFIEN,NODE,"BEFORE")=^AUPNVTRT(VFIEN,NODE)
End DoDot:2
End DoDot:1
+172 QUIT
+173 ;
ENCEVENT(VISITIEN,DONTKILL) ;Create the ^TMP("PKRENC",$J, array of all the
+1 ;information about one encounter.
+2 ;Parameters:
+3 ; VISITIEN Pointer to the Visit (#9000010)
+4 ; DONOTKILL is 1 if the output array is not to be killed before used
+5 ; and 0 or null if the array is to be killed (cleaned out)
+6 ;
+7 ; The encounter is returned in the array
+8 ; ^TMP("PXKENC",$J,pointer to visit)
+9 ;
+10 ;PX/183
IF $GET(VISITIEN)'>0
QUIT
+11 IF '$DATA(^AUPNVSIT(VISITIEN))
QUIT
+12 NEW CSTPIEN,ID,IND,NODE,NUMM,NUMP,NUMS,OLD800,PRV,PRVLIST,PS,TEMP,TMPSUB,SAS,VFIEN
+13 SET TMPSUB="PXKENC"
+14 if '$GET(DONTKILL)
KILL ^TMP(TMPSUB,$JOB)
+15 ;Visit and Credit Stop Visits
+16 SET NODE=""
+17 FOR
SET NODE=$ORDER(^AUPNVSIT(VISITIEN,NODE))
if (NODE'=+NODE)
QUIT
Begin DoDot:1
+18 IF NODE=800!(NODE=900)
Begin DoDot:2
+19 SET OLD800=""
+20 DO GETSAFORVISITDET^PXSPECAUTH(.SAS,.OLD800,VISITIEN)
+21 MERGE ^TMP(TMPSUB,$JOB,VISITIEN,"VST",VISITIEN,900)=SAS
+22 IF OLD800'=""
SET ^TMP(TMPSUB,$JOB,VISITIEN,"VST",VISITIEN,800)=OLD800
End DoDot:2
QUIT
+23 SET ^TMP(TMPSUB,$JOB,VISITIEN,"VST",VISITIEN,NODE)=^AUPNVSIT(VISITIEN,NODE)
End DoDot:1
+24 SET CSTPIEN=""
+25 FOR
SET CSTPIEN=$ORDER(^AUPNVSIT("AD",VISITIEN,CSTPIEN))
if CSTPIEN=""
QUIT
Begin DoDot:1
+26 IF "SC"'[$PIECE($GET(^AUPNVSIT(CSTPIEN,150)),"^",3)
QUIT
+27 SET NODE=""
+28 FOR
SET NODE=$ORDER(^AUPNVSIT(CSTPIEN,NODE))
if (NODE'=+NODE)
QUIT
Begin DoDot:2
+29 IF NODE=800!(NODE=900)
Begin DoDot:3
+30 SET OLD800=""
KILL SAS
+31 DO GETSAFORVISITDET^PXSPECAUTH(.SAS,.OLD800,CSTPIEN)
+32 MERGE ^TMP(TMPSUB,$JOB,VISITIEN,"CSTP",CSTPIEN,900)=SAS
+33 IF OLD800'=""
SET ^TMP(TMPSUB,$JOB,VISITIEN,"CSTP",CSTPIEN,800)=OLD800
End DoDot:3
QUIT
+34 SET ^TMP(TMPSUB,$JOB,VISITIEN,"CSTP",CSTPIEN,NODE)=^AUPNVSIT(CSTPIEN,NODE)
End DoDot:2
End DoDot:1
+35 ;
+36 ;V CPT
+37 SET VFIEN=""
+38 FOR
SET VFIEN=$ORDER(^AUPNVCPT("AD",VISITIEN,VFIEN))
if VFIEN=""
QUIT
Begin DoDot:1
+39 SET NODE=""
+40 FOR
SET NODE=$ORDER(^AUPNVCPT(VFIEN,NODE))
if (NODE'=+NODE)
QUIT
Begin DoDot:2
+41 IF NODE=801
QUIT
+42 ;Modifiers.
+43 IF NODE=1
Begin DoDot:3
+44 SET ^TMP(TMPSUB,$JOB,VISITIEN,"CPT",VFIEN,NODE,0)=^AUPNVCPT(VFIEN,NODE,0)
+45 SET IND=0
+46 FOR
SET IND=+$ORDER(^AUPNVCPT(VFIEN,NODE,IND))
if IND=0
QUIT
Begin DoDot:4
+47 SET ^TMP(TMPSUB,$JOB,VISITIEN,"CPT",VFIEN,NODE,IND,0)=^AUPNVCPT(VFIEN,NODE,IND,0)
End DoDot:4
End DoDot:3
+48 IF '$TEST
SET ^TMP(TMPSUB,$JOB,VISITIEN,"CPT",VFIEN,NODE)=^AUPNVCPT(VFIEN,NODE)
End DoDot:2
End DoDot:1
+49 ;
+50 ;V EXAM
+51 SET VFIEN=""
+52 FOR
SET VFIEN=$ORDER(^AUPNVXAM("AD",VISITIEN,VFIEN))
if VFIEN=""
QUIT
Begin DoDot:1
+53 SET NODE=""
+54 FOR
SET NODE=$ORDER(^AUPNVXAM(VFIEN,NODE))
if (NODE'=+NODE)
QUIT
Begin DoDot:2
+55 IF NODE=801
QUIT
+56 SET ^TMP(TMPSUB,$JOB,VISITIEN,"XAM",VFIEN,NODE)=^AUPNVXAM(VFIEN,NODE)
End DoDot:2
End DoDot:1
+57 ;
+58 ;V HF
+59 SET VFIEN=""
+60 FOR
SET VFIEN=$ORDER(^AUPNVHF("AD",VISITIEN,VFIEN))
if VFIEN=""
QUIT
Begin DoDot:1
+61 SET NODE=""
+62 FOR
SET NODE=$ORDER(^AUPNVHF(VFIEN,NODE))
if (NODE'=+NODE)
QUIT
Begin DoDot:2
+63 IF NODE=801
QUIT
+64 SET ^TMP(TMPSUB,$JOB,VISITIEN,"HF",VFIEN,NODE)=^AUPNVHF(VFIEN,NODE)
End DoDot:2
End DoDot:1
+65 ;
+66 ;V ICR
+67 SET VFIEN=""
+68 FOR
SET VFIEN=$ORDER(^AUPNVICR("AD",VISITIEN,VFIEN))
if VFIEN=""
QUIT
Begin DoDot:1
+69 SET NODE=""
+70 FOR
SET NODE=$ORDER(^AUPNVICR(VFIEN,NODE))
if (NODE'=+NODE)
QUIT
Begin DoDot:2
+71 IF NODE=801
QUIT
+72 SET ^TMP(TMPSUB,$JOB,VISITIEN,"ICR",VFIEN,NODE)=^AUPNVICR(VFIEN,NODE)
End DoDot:2
End DoDot:1
+73 ;
+74 ;V IMM
+75 SET VFIEN=""
+76 FOR
SET VFIEN=$ORDER(^AUPNVIMM("AD",VISITIEN,VFIEN))
if VFIEN=""
QUIT
Begin DoDot:1
+77 SET NODE=""
+78 FOR
SET NODE=$ORDER(^AUPNVIMM(VFIEN,NODE))
if (NODE'=+NODE)
QUIT
Begin DoDot:2
+79 IF NODE=801
QUIT
+80 ;Fields that are multiples.
+81 IF (NODE=2)!(NODE=3)!(NODE=11)
Begin DoDot:3
+82 SET ^TMP(TMPSUB,$JOB,VISITIEN,"IMM",VFIEN,NODE,0)=^AUPNVIMM(VFIEN,NODE,0)
+83 SET IND=0
+84 FOR
SET IND=+$ORDER(^AUPNVIMM(VFIEN,NODE,IND))
if IND=0
QUIT
Begin DoDot:4
+85 SET ^TMP(TMPSUB,$JOB,VISITIEN,"IMM",VFIEN,NODE,IND,0)=^AUPNVIMM(VFIEN,NODE,IND,0)
End DoDot:4
End DoDot:3
+86 IF '$TEST
SET ^TMP(TMPSUB,$JOB,VISITIEN,"IMM",VFIEN,NODE)=^AUPNVIMM(VFIEN,NODE)
End DoDot:2
End DoDot:1
+87 ;
+88 ;V PED
+89 SET VFIEN=""
+90 FOR
SET VFIEN=$ORDER(^AUPNVPED("AD",VISITIEN,VFIEN))
if VFIEN=""
QUIT
Begin DoDot:1
+91 SET NODE=""
+92 FOR
SET NODE=$ORDER(^AUPNVPED(VFIEN,NODE))
if (NODE'=+NODE)
QUIT
Begin DoDot:2
+93 IF NODE=801
QUIT
+94 SET ^TMP(TMPSUB,$JOB,VISITIEN,"PED",VFIEN,NODE)=^AUPNVPED(VFIEN,NODE)
End DoDot:2
End DoDot:1
+95 ;
+96 ;V POV
+97 SET VFIEN=""
+98 FOR
SET VFIEN=$ORDER(^AUPNVPOV("AD",VISITIEN,VFIEN))
if VFIEN=""
QUIT
Begin DoDot:1
+99 SET NODE=""
+100 FOR
SET NODE=$ORDER(^AUPNVPOV(VFIEN,NODE))
if (NODE'=+NODE)
QUIT
Begin DoDot:2
+101 IF NODE=801
QUIT
+102 IF NODE=800!(NODE=900)
Begin DoDot:3
+103 SET OLD800=""
+104 DO GETSAFORVPOVDET^PXSPECAUTH(.SAS,.OLD800,VFIEN)
+105 MERGE ^TMP(TMPSUB,$JOB,VISITIEN,"POV",VFIEN,900)=SAS
+106 IF OLD800'=""
SET ^TMP(TMPSUB,$JOB,VISITIEN,"POV",VFIEN,800)=OLD800
End DoDot:3
QUIT
+107 SET ^TMP(TMPSUB,$JOB,VISITIEN,"POV",VFIEN,NODE)=^AUPNVPOV(VFIEN,NODE)
+108 ;Check for bad Provider Narrative Category pointer.
+109 IF (NODE=802)
IF (^AUPNVPOV(VFIEN,NODE)'>0)
SET ^TMP(TMPSUB,$JOB,VISITIEN,"POV",VFIEN,NODE)=""
End DoDot:2
End DoDot:1
+110 ;
+111 ;V PROVIDER
+112 SET VFIEN=""
+113 FOR
SET VFIEN=$ORDER(^AUPNVPRV("AD",VISITIEN,VFIEN))
if VFIEN=""
QUIT
Begin DoDot:1
+114 SET NODE=""
+115 FOR
SET NODE=$ORDER(^AUPNVPRV(VFIEN,NODE))
if (NODE'=+NODE)
QUIT
Begin DoDot:2
+116 IF NODE=801
QUIT
+117 SET ^TMP(TMPSUB,$JOB,VISITIEN,"PRV",VFIEN,NODE)=^AUPNVPRV(VFIEN,NODE)
+118 IF NODE=0
Begin DoDot:3
+119 SET TEMP=^AUPNVPRV(VFIEN,NODE)
SET PRV=$PIECE(TEMP,U,1)
SET PS=$PIECE(TEMP,U,4)
+120 ;Primary/Secondary is a required field but it is possible for it
+121 ;to be missing.
+122 IF PS=""
SET PS="M"
+123 SET PRVLIST(PRV,"CNT")=$GET(PRVLIST(PRV,"CNT"))+1
+124 SET PRVLIST(PRV,PS,"CNT")=$GET(PRVLIST(PRV,PS,"CNT"))+1
+125 SET PRVLIST(PRV,PS,PRVLIST(PRV,PS,"CNT"))=VFIEN
End DoDot:3
End DoDot:2
End DoDot:1
+126 ;Remove duplicates.
+127 SET PRV=""
+128 FOR
SET PRV=$ORDER(PRVLIST(PRV))
if PRV=""
QUIT
Begin DoDot:1
+129 IF PRVLIST(PRV,"CNT")=1
QUIT
+130 SET NUMM=+$GET(PRVLIST(PRV,"M","CNT"))
+131 SET NUMP=+$GET(PRVLIST(PRV,"P","CNT"))
+132 SET NUMS=+$GET(PRVLIST(PRV,"S","CNT"))
+133 ;Remove any entries that are missing the Primary/Secondary designation.
+134 IF NUMM>0
FOR IND=1:1:NUMM
SET VFIEN=PRVLIST(PRV,"M",IND)
KILL ^TMP(TMPSUB,$JOB,VISITIEN,"PRV",VFIEN)
+135 ;If this provider is listed as primary more than once, delete the other primaries.
+136 IF NUMP>1
Begin DoDot:2
+137 FOR IND=2:1:NUMP
SET VFIEN=PRVLIST(PRV,"P",IND)
KILL ^TMP(TMPSUB,$JOB,VISITIEN,"PRV",VFIEN)
+138 ;If this provider is a primary, delete all its secondaries and missing.
End DoDot:2
+139 IF NUMP>0
Begin DoDot:2
+140 FOR IND=1:1:NUMS
SET VFIEN=PRVLIST(PRV,"S",IND)
KILL ^TMP(TMPSUB,$JOB,VISITIEN,"PRV",VFIEN)
+141 SET NUMS=0
End DoDot:2
+142 ;If this provider is not primary, only keep the first secondary.
+143 IF NUMS>1
Begin DoDot:2
+144 FOR IND=2:1:NUMS
Begin DoDot:3
+145 SET VFIEN=PRVLIST(PRV,"S",IND)
+146 KILL ^TMP(TMPSUB,$JOB,VISITIEN,"PRV",VFIEN)
End DoDot:3
End DoDot:2
End DoDot:1
+147 ;
+148 ;V SC
+149 SET VFIEN=""
+150 FOR
SET VFIEN=$ORDER(^AUPNVSC("AD",VISITIEN,VFIEN))
if VFIEN=""
QUIT
Begin DoDot:1
+151 SET NODE=""
+152 FOR
SET NODE=$ORDER(^AUPNVSC(VFIEN,NODE))
if (NODE'=+NODE)
QUIT
Begin DoDot:2
+153 IF NODE=801
QUIT
+154 SET ^TMP(TMPSUB,$JOB,VISITIEN,"SC",VFIEN,NODE)=^AUPNVSC(VFIEN,NODE)
End DoDot:2
End DoDot:1
+155 ;
+156 ;V SKIN
+157 SET VFIEN=""
+158 FOR
SET VFIEN=$ORDER(^AUPNVSK("AD",VISITIEN,VFIEN))
if VFIEN=""
QUIT
Begin DoDot:1
+159 SET NODE=""
+160 FOR
SET NODE=$ORDER(^AUPNVSK(VFIEN,NODE))
if (NODE'=+NODE)
QUIT
Begin DoDot:2
+161 IF NODE=801
QUIT
+162 SET ^TMP(TMPSUB,$JOB,VISITIEN,"SK",VFIEN,NODE)=^AUPNVSK(VFIEN,NODE)
End DoDot:2
End DoDot:1
+163 ;
+164 ;V TRT
+165 SET VFIEN=""
+166 FOR
SET VFIEN=$ORDER(^AUPNVTRT("AD",VISITIEN,VFIEN))
if VFIEN=""
QUIT
Begin DoDot:1
+167 SET NODE=""
+168 FOR
SET NODE=$ORDER(^AUPNVTRT(VFIEN,NODE))
if (NODE'=+NODE)
QUIT
Begin DoDot:2
+169 IF NODE=801
QUIT
+170 SET ^TMP(TMPSUB,$JOB,VISITIEN,"TRT",VFIEN,NODE)=^AUPNVTRT(VFIEN,NODE)
End DoDot:2
End DoDot:1
+171 QUIT
+172 ;
