PXAI ;ISL/JVS,ISA/KWP,ESW - PCE DRIVING RTN FOR 'DATA2PCE' API ; 6/20/03 11:15am
;;1.0;PCE PATIENT CARE ENCOUNTER;**15,74,69,102,111,112**;Aug 12, 1996
Q
;
;+ 1 2 3 4 5 6 7 8 9
DATA2PCE(PXADATA,PXAPKG,PXASOURC,PXAVISIT,PXAUSER,PXANOT,ERRRET,PXAPREDT,PXAPROB) ;+API to pass data for add/edit/delete to PCE.
;+ PXADATA (required)
;+ PXAPKG (required)
;+ PXASOURC (required)
;+ PXAVISIT (optional) is pointer to a visit for which the data is to
;+ be related. If the visit is not know then there must be
;+ the ENCOUNTER nodes needed to lookup/create the visit.
;+ PXAUSER (optional) this is a pointer to the user adding the data.
;+ PXANOT (optional) set to 1 if errors are to be displayed to the screen should only be set while writing and debugging the initial code.
;+ ERRRET (optional) passed by reference. If present will return PXKERROR
;+ array elements to the caller.
;+ PXAPREDT (optional) Set to 1 if you want to edit the Primary Provder
;+ only use if for the moment that editing is being done. (dangeous)
;+ .PXAPROB (optional) A dotted variable name. When errors and
;+ warnings occur, They will be passed back in the form
;+ of an array with the general description of the problem.
;+ IF ERROR1 - (GENERAL ERRORS)
;+ PXAPROB($J,SUBSCRIPT,"ERROR1",PASSED IN 'FILE',PASSED IN FIELD,
;+ SUBSCRIPT FROM PXADATA)
;+ PXAPROB(23432234,2,"ERROR1","PROVIDER","NAME",7)="BECAUSE..."
;+ IF WARNING2 - (GENERAL WARNINGS)
;+ PXAPROB($J,SUBSCRIPT,"WARNING2",PASSED IN 'FILE',PASSED IN FIELD,
;+ SUBSCRIPT FROM PXADATA)
;+ PXAPROB(23432234,3,"WARNING2","PROCEDURE","QTY",3)="BECAUSE..."
;+ IF WARNING3 - (WARNINGS FOR SERVICE CONNECTION)
;+ PXAPROB($J,1,"WARNING3","ENCOUNTER",1,"AO")=REASON
;+ PXAPROB($J,1,"WARNING3","ENCOUNTER",1,"EC")=REASON
;+ PXAPROB($J,1,"WARNING3","ENCOUNTER",1,"IR")=REASON
;+ PXAPROB($J,1,"WARNING3","ENCOUNTER",1,"SC")=REASON
;+ PXAPROB($J,1,"WARNING3","ENCOUNTER",1,"MST")=REASON
;+ PXAPROB($J,1,"WARNING3","ENCOUNTER",1,"HNC")=REASON
;+ IF ERROR4 - (PROBLEM LIST ERRORS)
;+ PXAPROB($J,6,"ERROR4","PX/DL",(SUBSCRIPT FROM PXADATA))=REASON
;+
;+
;+
;+ Returns:
;+ 1 if no errors and process completely
;+ -1 if errors occurred but processed completely as possible
;+ -2 if could not get a visit
;+ -3 if called incorrectly
;
NEW ;--NEW VARIABLES
N NOVSIT,PXAK,DFN,PXAERRF,PXADEC,PXELAP,PXASUB
N PATIENT,VALQUIET,PRIMFND
K PXAERROR,PXKERROR,PXAERR,PRVDR
S PXASUB=0,VALQUIET=1
; needs to look up if not passed.
I '$G(PXAVISIT),'$D(@PXADATA@("ENCOUNTER")) Q -3
I $G(PXAUSER)<1 S PXAUSER=DUZ
;
K ^TMP("PXK",$J),^TMP("DIERR",$J),^TMP("PXAIADDPRV",$J)
SOR ;--SOURCE
I PXAPKG=+PXAPKG S PXAPKG=PXAPKG
E S PXAPKG=$$PKG2IEN^VSIT(PXAPKG)
I PXASOURC=+PXASOURC S PXASOURC=PXASOURC
E S PXASOURC=$$SOURCE^PXAPIUTL(PXASOURC)
;
D TMPSOURC^PXAPIUTL(PXASOURC) ;-SAVES & CREATES ^TMP("PXK",$J,"SOR")
VST ;--VISIT
;--KILL VISIT
I $G(PXAVISIT) D VPTR^PXAIVSTV I $G(PXAERRF) D ERR Q -2
D VST^PXAIVST
I $G(PXAVISIT)<0 Q -2
I $G(PXAERRF) D ERR K PXAERR Q -2
PRV ;--PROVIDER
S PATIENT=$P($G(^AUPNVSIT(PXAVISIT,0)),"^",5)
S (PXAK,PRIMFND)=0
F S PXAK=$O(@PXADATA@("PROVIDER",PXAK)) Q:(PRIMFND)!(PXAK="") D
.I $D(@PXADATA@("PROVIDER",PXAK,"PRIMARY")) D
..S PRIMFND=$G(@PXADATA@("PROVIDER",PXAK,"PRIMARY"))
I 'PRIMFND D ;Check for each provider's status as Primary or Secondary
.S PXAK=0 F S PXAK=$O(@PXADATA@("PROVIDER",PXAK)) Q:PXAK="" D
..I '$D(@PXADATA@("PROVIDER",PXAK,"PRIMARY")) D PROVDRST
S PXAK=0 F S PXAK=$O(@PXADATA@("PROVIDER",PXAK)) Q:PXAK="" D
. D PRV^PXAIPRV I $G(PXAERRF) D ERR
K PRI ;--FLAG FOR PRIMARY PROVIDER
K PXAERR
CPT ;--PROCEDURE
S PXAK=0 F S PXAK=$O(@PXADATA@("PROCEDURE",PXAK)) Q:PXAK="" D
. D CPT^PXAICPT I $G(PXAERRF) D ERR
K PXAERR
;
POV ;--DIAGNOSIS
S (PXAK,PRIMFND)=0
F S PXAK=$O(@PXADATA@("DX/PL",PXAK)) Q:(PXAK="") D Q:PRIMFND
.I +$G(@PXADATA@("DX/PL",PXAK,"PRIMARY"))=1 D
..S PRIMFND=$G(@PXADATA@("DX/PL",PXAK,"DIAGNOSIS"))
I $D(@PXADATA@("DX/PL")) D POVPRM(PXAVISIT,PRIMFND,.PXADATA) D
.S PXAK=0 F S PXAK=$O(@PXADATA@("DX/PL",PXAK)) Q:PXAK="" D
..D POV^PXAIPOV I $G(PXAERRF) D ERR
K PXAERR
;
EDU ;--PATIENT EDUCATION
S PXAK=0 F S PXAK=$O(@PXADATA@("PATIENT ED",PXAK)) Q:PXAK="" D
. D EDU^PXAIPED I $G(PXAERRF) D ERR
K PXAERR
;
EXAM ;--EXAMINATION
S PXAK=0 F S PXAK=$O(@PXADATA@("EXAM",PXAK)) Q:PXAK="" D
. D EXAM^PXAIXAM I $G(PXAERRF) D ERR
K PXAERR
;
HF ;--HEALTH FACTOR
S PXAK=0 F S PXAK=$O(@PXADATA@("HEALTH FACTOR",PXAK)) Q:PXAK="" D
. D HF^PXAIHF I $G(PXAERRF) D ERR
K PXAERR
;
IMM ;--IMMUNIZATION
S PXAK=0 F S PXAK=$O(@PXADATA@("IMMUNIZATION",PXAK)) Q:PXAK="" D
. D IMM^PXAIIMM I $G(PXAERRF) D ERR
K PXAERR
;
SKIN ;--SKIN TEST
S PXAK=0 F S PXAK=$O(@PXADATA@("SKIN TEST",PXAK)) Q:PXAK="" D
. D SKIN^PXAISK I $G(PXAERRF) D ERR
K PXAERR
;
;
D OTHER^PXAIPRV
;
;
I $D(^TMP("PXK",$J)) D
. D EN1^PXKMAIN
. M ERRRET=PXKERROR
. D PRIM^PXAIPRV K PRVDR
. D EVENT^PXKMAIN
K ^TMP("PXK",$J),PXAERR,PXKERROR
Q $S($G(PXAERRF):-1,1:1)
;
;
EXIT ;--EXIT AND CLEAN UP
D EVENT^PXKMAIN
K ^TMP("PXK",$J),PRVDR
K PXAERR
Q
;-----------------SUBROUTINES-----------------------
ERR ;
;
;
I '$D(PXADI("DIALOG")) Q
N NODE,SCREEN
S PXAERR(1)=$G(PXADATA),PXAERR(2)=$G(PXAPKG),PXAERR(3)=$G(PXASOURC)
S PXAERR(4)=$G(PXAVISIT),PXAERR(5)=$G(PXAUSER)_" "_$P($G(^VA(200,PXAUSER,0)),"^",1)
I $G(PXANOT)=1 D EXTERNAL
E D INTERNAL
D ARRAY^PXAICPTV
K PXADI("DIALOG")
Q
;
EXTERNAL ;---SEND ERRORS TO SCREEN
W !,"-----------------------------------------------------------------"
D BLD^DIALOG($G(PXADI("DIALOG")),.PXAERR,"","SCREEN","F")
D MSG^DIALOG("ESW","",50,10,"SCREEN")
;
Q
INTERNAL ;---SET ERRORS TO GLOBAL ARRAY
S NODE=PXADATA
D BLD^DIALOG($G(PXADI("DIALOG")),.PXAERR,.PXAERR,NODE,"F")
S NODE=$NA(@PXADATA@("DIERR",$J)) D MSG^DIALOG("ESW","",50,10,NODE)
Q
;
PROVDRST ; Check provider status (Primary or Secondary)
N PRVIEN,DETS,DIC,DR,DA,DIQ,PRI,PRVPRIM
I $G(PXAK)="" QUIT
S PRVIEN=0
F S PRVIEN=$O(^AUPNVPRV("AD",PXAVISIT,PRVIEN)) Q:PRVIEN="" D
.S DETS=$G(^AUPNVPRV(PRVIEN,0))
.I $P(DETS,U)=$G(@PXADATA@("PROVIDER",PXAK,"NAME")) D
..S DIC=9000010.06,DR=.04,DA=PRVIEN
..S DIQ="PRVPRIM(",DIQ(0)="EI" D EN^DIQ1
..S PRI=$E($G(PRVPRIM(9000010.06,DA,DR,"E")),1,1)
..S @PXADATA@("PROVIDER",PXAK,"PRIMARY")=$S(PRI="P":1,1:0)
Q
POVPRM(VISIT,PRIMFND,POVARR) ;
N PRVIEN,DETS,STOP,LPXAK,ORDX,NDX,ORDXP
S PRVIEN=0
;create array of existing DX; ORDX - pointer to ^ICD9(
F S PRVIEN=$O(^AUPNVPOV("AD",PXAVISIT,PRVIEN)) Q:PRVIEN="" D
.S DETS=$G(^AUPNVPOV(PRVIEN,0)),ORDX=$P(DETS,U)
.S ORDX(ORDX)=PRVIEN I $P(DETS,U,12)="P" S ORDXP(ORDX)=""
; create array of passed DX; NDX - pointer to ^ICD9(
S PXAK=0 F S PXAK=$O(@POVARR@("DX/PL",PXAK)) Q:PXAK="" D
.S NDX=$G(@POVARR@("DX/PL",PXAK,"DIAGNOSIS")) S NDX(NDX)=PXAK
; force entry of originally primary diagnosis with "S" flag
I PRIMFND S ORDX="" D
.F S ORDX=$O(ORDXP(ORDX)) Q:ORDX="" I PRIMFND'=ORDX D
..I $D(NDX(ORDX)) S @POVARR@("DX/PL",NDX(ORDX),"PRIMARY")=0
..E D
...S LPXAK=$O(@POVARR@("DX/PL",""),-1)
...S @POVARR@("DX/PL",LPXAK+1,"DIAGNOSIS")=ORDX
...S @POVARR@("DX/PL",LPXAK+1,"PRIMARY")=0
Q
;
PXAI ;ISL/JVS,ISA/KWP,ESW - PCE DRIVING RTN FOR 'DATA2PCE' API ; 6/20/03 11:15am
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**15,74,69,102,111,112**;Aug 12, 1996
+2 QUIT
+3 ;
+4 ;+ 1 2 3 4 5 6 7 8 9
DATA2PCE(PXADATA,PXAPKG,PXASOURC,PXAVISIT,PXAUSER,PXANOT,ERRRET,PXAPREDT,PXAPROB) ;+API to pass data for add/edit/delete to PCE.
+1 ;+ PXADATA (required)
+2 ;+ PXAPKG (required)
+3 ;+ PXASOURC (required)
+4 ;+ PXAVISIT (optional) is pointer to a visit for which the data is to
+5 ;+ be related. If the visit is not know then there must be
+6 ;+ the ENCOUNTER nodes needed to lookup/create the visit.
+7 ;+ PXAUSER (optional) this is a pointer to the user adding the data.
+8 ;+ PXANOT (optional) set to 1 if errors are to be displayed to the screen should only be set while writing and debugging the initial code.
+9 ;+ ERRRET (optional) passed by reference. If present will return PXKERROR
+10 ;+ array elements to the caller.
+11 ;+ PXAPREDT (optional) Set to 1 if you want to edit the Primary Provder
+12 ;+ only use if for the moment that editing is being done. (dangeous)
+13 ;+ .PXAPROB (optional) A dotted variable name. When errors and
+14 ;+ warnings occur, They will be passed back in the form
+15 ;+ of an array with the general description of the problem.
+16 ;+ IF ERROR1 - (GENERAL ERRORS)
+17 ;+ PXAPROB($J,SUBSCRIPT,"ERROR1",PASSED IN 'FILE',PASSED IN FIELD,
+18 ;+ SUBSCRIPT FROM PXADATA)
+19 ;+ PXAPROB(23432234,2,"ERROR1","PROVIDER","NAME",7)="BECAUSE..."
+20 ;+ IF WARNING2 - (GENERAL WARNINGS)
+21 ;+ PXAPROB($J,SUBSCRIPT,"WARNING2",PASSED IN 'FILE',PASSED IN FIELD,
+22 ;+ SUBSCRIPT FROM PXADATA)
+23 ;+ PXAPROB(23432234,3,"WARNING2","PROCEDURE","QTY",3)="BECAUSE..."
+24 ;+ IF WARNING3 - (WARNINGS FOR SERVICE CONNECTION)
+25 ;+ PXAPROB($J,1,"WARNING3","ENCOUNTER",1,"AO")=REASON
+26 ;+ PXAPROB($J,1,"WARNING3","ENCOUNTER",1,"EC")=REASON
+27 ;+ PXAPROB($J,1,"WARNING3","ENCOUNTER",1,"IR")=REASON
+28 ;+ PXAPROB($J,1,"WARNING3","ENCOUNTER",1,"SC")=REASON
+29 ;+ PXAPROB($J,1,"WARNING3","ENCOUNTER",1,"MST")=REASON
+30 ;+ PXAPROB($J,1,"WARNING3","ENCOUNTER",1,"HNC")=REASON
+31 ;+ IF ERROR4 - (PROBLEM LIST ERRORS)
+32 ;+ PXAPROB($J,6,"ERROR4","PX/DL",(SUBSCRIPT FROM PXADATA))=REASON
+33 ;+
+34 ;+
+35 ;+
+36 ;+ Returns:
+37 ;+ 1 if no errors and process completely
+38 ;+ -1 if errors occurred but processed completely as possible
+39 ;+ -2 if could not get a visit
+40 ;+ -3 if called incorrectly
+41 ;
NEW ;--NEW VARIABLES
+1 NEW NOVSIT,PXAK,DFN,PXAERRF,PXADEC,PXELAP,PXASUB
+2 NEW PATIENT,VALQUIET,PRIMFND
+3 KILL PXAERROR,PXKERROR,PXAERR,PRVDR
+4 SET PXASUB=0
SET VALQUIET=1
+5 ; needs to look up if not passed.
+6 IF '$GET(PXAVISIT)
IF '$DATA(@PXADATA@("ENCOUNTER"))
QUIT -3
+7 IF $GET(PXAUSER)<1
SET PXAUSER=DUZ
+8 ;
+9 KILL ^TMP("PXK",$JOB),^TMP("DIERR",$JOB),^TMP("PXAIADDPRV",$JOB)
SOR ;--SOURCE
+1 IF PXAPKG=+PXAPKG
SET PXAPKG=PXAPKG
+2 IF '$TEST
SET PXAPKG=$$PKG2IEN^VSIT(PXAPKG)
+3 IF PXASOURC=+PXASOURC
SET PXASOURC=PXASOURC
+4 IF '$TEST
SET PXASOURC=$$SOURCE^PXAPIUTL(PXASOURC)
+5 ;
+6 ;-SAVES & CREATES ^TMP("PXK",$J,"SOR")
DO TMPSOURC^PXAPIUTL(PXASOURC)
VST ;--VISIT
+1 ;--KILL VISIT
+2 IF $GET(PXAVISIT)
DO VPTR^PXAIVSTV
IF $GET(PXAERRF)
DO ERR
QUIT -2
+3 DO VST^PXAIVST
+4 IF $GET(PXAVISIT)<0
QUIT -2
+5 IF $GET(PXAERRF)
DO ERR
KILL PXAERR
QUIT -2
PRV ;--PROVIDER
+1 SET PATIENT=$PIECE($GET(^AUPNVSIT(PXAVISIT,0)),"^",5)
+2 SET (PXAK,PRIMFND)=0
+3 FOR
SET PXAK=$ORDER(@PXADATA@("PROVIDER",PXAK))
IF (PRIMFND)!(PXAK="")
QUIT
Begin DoDot:1
+4 IF $DATA(@PXADATA@("PROVIDER",PXAK,"PRIMARY"))
Begin DoDot:2
+5 SET PRIMFND=$GET(@PXADATA@("PROVIDER",PXAK,"PRIMARY"))
End DoDot:2
End DoDot:1
+6 ;Check for each provider's status as Primary or Secondary
IF 'PRIMFND
Begin DoDot:1
+7 SET PXAK=0
FOR
SET PXAK=$ORDER(@PXADATA@("PROVIDER",PXAK))
IF PXAK=""
QUIT
Begin DoDot:2
+8 IF '$DATA(@PXADATA@("PROVIDER",PXAK,"PRIMARY"))
DO PROVDRST
End DoDot:2
End DoDot:1
+9 SET PXAK=0
FOR
SET PXAK=$ORDER(@PXADATA@("PROVIDER",PXAK))
IF PXAK=""
QUIT
Begin DoDot:1
+10 DO PRV^PXAIPRV
IF $GET(PXAERRF)
DO ERR
End DoDot:1
+11 ;--FLAG FOR PRIMARY PROVIDER
KILL PRI
+12 KILL PXAERR
CPT ;--PROCEDURE
+1 SET PXAK=0
FOR
SET PXAK=$ORDER(@PXADATA@("PROCEDURE",PXAK))
IF PXAK=""
QUIT
Begin DoDot:1
+2 DO CPT^PXAICPT
IF $GET(PXAERRF)
DO ERR
End DoDot:1
+3 KILL PXAERR
+4 ;
POV ;--DIAGNOSIS
+1 SET (PXAK,PRIMFND)=0
+2 FOR
SET PXAK=$ORDER(@PXADATA@("DX/PL",PXAK))
IF (PXAK="")
QUIT
Begin DoDot:1
+3 IF +$GET(@PXADATA@("DX/PL",PXAK,"PRIMARY"))=1
Begin DoDot:2
+4 SET PRIMFND=$GET(@PXADATA@("DX/PL",PXAK,"DIAGNOSIS"))
End DoDot:2
End DoDot:1
IF PRIMFND
QUIT
+5 IF $DATA(@PXADATA@("DX/PL"))
DO POVPRM(PXAVISIT,PRIMFND,.PXADATA)
Begin DoDot:1
+6 SET PXAK=0
FOR
SET PXAK=$ORDER(@PXADATA@("DX/PL",PXAK))
IF PXAK=""
QUIT
Begin DoDot:2
+7 DO POV^PXAIPOV
IF $GET(PXAERRF)
DO ERR
End DoDot:2
End DoDot:1
+8 KILL PXAERR
+9 ;
EDU ;--PATIENT EDUCATION
+1 SET PXAK=0
FOR
SET PXAK=$ORDER(@PXADATA@("PATIENT ED",PXAK))
IF PXAK=""
QUIT
Begin DoDot:1
+2 DO EDU^PXAIPED
IF $GET(PXAERRF)
DO ERR
End DoDot:1
+3 KILL PXAERR
+4 ;
EXAM ;--EXAMINATION
+1 SET PXAK=0
FOR
SET PXAK=$ORDER(@PXADATA@("EXAM",PXAK))
IF PXAK=""
QUIT
Begin DoDot:1
+2 DO EXAM^PXAIXAM
IF $GET(PXAERRF)
DO ERR
End DoDot:1
+3 KILL PXAERR
+4 ;
HF ;--HEALTH FACTOR
+1 SET PXAK=0
FOR
SET PXAK=$ORDER(@PXADATA@("HEALTH FACTOR",PXAK))
IF PXAK=""
QUIT
Begin DoDot:1
+2 DO HF^PXAIHF
IF $GET(PXAERRF)
DO ERR
End DoDot:1
+3 KILL PXAERR
+4 ;
IMM ;--IMMUNIZATION
+1 SET PXAK=0
FOR
SET PXAK=$ORDER(@PXADATA@("IMMUNIZATION",PXAK))
IF PXAK=""
QUIT
Begin DoDot:1
+2 DO IMM^PXAIIMM
IF $GET(PXAERRF)
DO ERR
End DoDot:1
+3 KILL PXAERR
+4 ;
SKIN ;--SKIN TEST
+1 SET PXAK=0
FOR
SET PXAK=$ORDER(@PXADATA@("SKIN TEST",PXAK))
IF PXAK=""
QUIT
Begin DoDot:1
+2 DO SKIN^PXAISK
IF $GET(PXAERRF)
DO ERR
End DoDot:1
+3 KILL PXAERR
+4 ;
+5 ;
+6 DO OTHER^PXAIPRV
+7 ;
+8 ;
+9 IF $DATA(^TMP("PXK",$JOB))
Begin DoDot:1
+10 DO EN1^PXKMAIN
+11 MERGE ERRRET=PXKERROR
+12 DO PRIM^PXAIPRV
KILL PRVDR
+13 DO EVENT^PXKMAIN
End DoDot:1
+14 KILL ^TMP("PXK",$JOB),PXAERR,PXKERROR
+15 QUIT $SELECT($GET(PXAERRF):-1,1:1)
+16 ;
+17 ;
EXIT ;--EXIT AND CLEAN UP
+1 DO EVENT^PXKMAIN
+2 KILL ^TMP("PXK",$JOB),PRVDR
+3 KILL PXAERR
+4 QUIT
+5 ;-----------------SUBROUTINES-----------------------
ERR ;
+1 ;
+2 ;
+3 IF '$DATA(PXADI("DIALOG"))
QUIT
+4 NEW NODE,SCREEN
+5 SET PXAERR(1)=$GET(PXADATA)
SET PXAERR(2)=$GET(PXAPKG)
SET PXAERR(3)=$GET(PXASOURC)
+6 SET PXAERR(4)=$GET(PXAVISIT)
SET PXAERR(5)=$GET(PXAUSER)_" "_$PIECE($GET(^VA(200,PXAUSER,0)),"^",1)
+7 IF $GET(PXANOT)=1
DO EXTERNAL
+8 IF '$TEST
DO INTERNAL
+9 DO ARRAY^PXAICPTV
+10 KILL PXADI("DIALOG")
+11 QUIT
+12 ;
EXTERNAL ;---SEND ERRORS TO SCREEN
+1 WRITE !,"-----------------------------------------------------------------"
+2 DO BLD^DIALOG($GET(PXADI("DIALOG")),.PXAERR,"","SCREEN","F")
+3 DO MSG^DIALOG("ESW","",50,10,"SCREEN")
+4 ;
+5 QUIT
INTERNAL ;---SET ERRORS TO GLOBAL ARRAY
+1 SET NODE=PXADATA
+2 DO BLD^DIALOG($GET(PXADI("DIALOG")),.PXAERR,.PXAERR,NODE,"F")
+3 SET NODE=$NAME(@PXADATA@("DIERR",$JOB))
DO MSG^DIALOG("ESW","",50,10,NODE)
+4 QUIT
+5 ;
PROVDRST ; Check provider status (Primary or Secondary)
+1 NEW PRVIEN,DETS,DIC,DR,DA,DIQ,PRI,PRVPRIM
+2 IF $GET(PXAK)=""
QUIT
+3 SET PRVIEN=0
+4 FOR
SET PRVIEN=$ORDER(^AUPNVPRV("AD",PXAVISIT,PRVIEN))
IF PRVIEN=""
QUIT
Begin DoDot:1
+5 SET DETS=$GET(^AUPNVPRV(PRVIEN,0))
+6 IF $PIECE(DETS,U)=$GET(@PXADATA@("PROVIDER",PXAK,"NAME"))
Begin DoDot:2
+7 SET DIC=9000010.06
SET DR=.04
SET DA=PRVIEN
+8 SET DIQ="PRVPRIM("
SET DIQ(0)="EI"
DO EN^DIQ1
+9 SET PRI=$EXTRACT($GET(PRVPRIM(9000010.06,DA,DR,"E")),1,1)
+10 SET @PXADATA@("PROVIDER",PXAK,"PRIMARY")=$SELECT(PRI="P":1,1:0)
End DoDot:2
End DoDot:1
+11 QUIT
POVPRM(VISIT,PRIMFND,POVARR) ;
+1 NEW PRVIEN,DETS,STOP,LPXAK,ORDX,NDX,ORDXP
+2 SET PRVIEN=0
+3 ;create array of existing DX; ORDX - pointer to ^ICD9(
+4 FOR
SET PRVIEN=$ORDER(^AUPNVPOV("AD",PXAVISIT,PRVIEN))
IF PRVIEN=""
QUIT
Begin DoDot:1
+5 SET DETS=$GET(^AUPNVPOV(PRVIEN,0))
SET ORDX=$PIECE(DETS,U)
+6 SET ORDX(ORDX)=PRVIEN
IF $PIECE(DETS,U,12)="P"
SET ORDXP(ORDX)=""
End DoDot:1
+7 ; create array of passed DX; NDX - pointer to ^ICD9(
+8 SET PXAK=0
FOR
SET PXAK=$ORDER(@POVARR@("DX/PL",PXAK))
IF PXAK=""
QUIT
Begin DoDot:1
+9 SET NDX=$GET(@POVARR@("DX/PL",PXAK,"DIAGNOSIS"))
SET NDX(NDX)=PXAK
End DoDot:1
+10 ; force entry of originally primary diagnosis with "S" flag
+11 IF PRIMFND
SET ORDX=""
Begin DoDot:1
+12 FOR
SET ORDX=$ORDER(ORDXP(ORDX))
IF ORDX=""
QUIT
IF PRIMFND'=ORDX
Begin DoDot:2
+13 IF $DATA(NDX(ORDX))
SET @POVARR@("DX/PL",NDX(ORDX),"PRIMARY")=0
+14 IF '$TEST
Begin DoDot:3
+15 SET LPXAK=$ORDER(@POVARR@("DX/PL",""),-1)
+16 SET @POVARR@("DX/PL",LPXAK+1,"DIAGNOSIS")=ORDX
+17 SET @POVARR@("DX/PL",LPXAK+1,"PRIMARY")=0
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
