PXAIPOV ;ISL/JVS,PKR,ESW - SET THE DIAGNOSIS/PROBLEM LIST NODES ;Oct 29, 2025@14:09:42
;;1.0;PCE PATIENT CARE ENCOUNTER;**28,73,69,108,112,130,124,174,168,203,199,211,228,244**;Aug 12, 1996;Build 37
;
Q
POV ;--CREATE DIAGNOSIS
;
SET ;--SET AND NEW VARIABLES
N AFTER0,AFTER12,AFTER800,AFTER801,AFTER802,AFTER811,AFTER812,AFTER8A
N BEFOR0,BEFOR12,BEFOR800,BEFOR801,BEFOR802,BEFOR811,BEFOR812,BEFORE900,CODE,FPRI
N EVENTDT,GMPSAVED,IENB,J,LNARR,NOPLLIST,PIECE,POVI,PRI,PRVDR,PXAA,PXAAX,PXAB,PXARRAY
N PXAIVDT,PXBCNT,PXBCNTPL,PXBKY,PXBPMT,PXBSAM,PXBSKY,PXDIGNS,PXKDONE,PXSAS
N STOP,SUB,VAR,VNODE,VSA,SAINPUTS,TMPSA
;
K PXAERR
S PXAERR(8)=PXAK
S PXAERR(7)="DX/PL"
;
S SUB="" F S SUB=$O(@PXADATA@("DX/PL",PXAK,SUB)) Q:SUB="" D
.I $P(SUB," ")="PL" S CODE=$P(SUB," ",2) I CODE'="",$$FINDBYCODE^PXSPECAUTH(CODE) S PXSAS(CODE)=@PXADATA@("DX/PL",PXAK,SUB) Q
.S PXAA(SUB)=@PXADATA@("DX/PL",PXAK,SUB)
;
;--VALIDATE ENOUGH DATA
D VAL^PXAIPOVV Q:$G(STOP)=1
;
SETVARA ;--SET VISIT VARIABLES
S $P(AFTER0,U,1)=$G(PXAA("DIAGNOSIS"))
I $G(PXAA("DELETE")) S $P(AFTER0,U,1)="@"
S $P(AFTER0,U,2)=$G(PATIENT),PXAA("PATIENT")=$G(PATIENT)
S $P(AFTER0,U,3)=$G(PXAVISIT)
;If Provider Narrative is not passed it is generated in VAL^PXAIPOVV.
S $P(AFTER0,U,4)=+$$PROVNARR^PXAPI($G(PXAA("NARRATIVE")),9000010.07)
I $P(AFTER0,U,4)'>0 D VAL04^PXAIPOVV,ERR^PXAI("NARRATIVE",1) Q:$D(STOP)
;PX*1*124
S PRI=$G(PXAA("PRIMARY"))
S $P(AFTER0,U,12)=$S(PRI=1:"P",PRI="P":"P",1:"S")
;--ADDED FOR PATCH 28
S $P(AFTER0,U,15)=$G(PXAA("LEXICON TERM"))
S $P(AFTER0,U,16)=$G(PXAA("PL IEN"))
S $P(AFTER0,U,17)=$G(PXAA("ORD/RES"))
;--END OF NEW PATCH 28
S $P(AFTER12,U,1)=$G(PXAA("EVENT D/T"))
S $P(AFTER12,U,2)=$G(PXAA("ORD PROVIDER"))
S $P(AFTER12,U,4)=$G(PXAA("ENC PROVIDER"))
;PX*1*108
I $G(PXAA("ENC PROVIDER"))]"",'$G(PXAA("DELETE")) D
.S ^TMP("PXAIADDPRV",$J,$G(PXAA("ENC PROVIDER")))="ENC"
I $G(PXAA("ORD PROVIDER"))]"",'$G(PXAA("DELETE")) D
.S ^TMP("PXAIADDPRV",$J,$G(PXAA("ORD PROVIDER")))="ORD"
;
I $G(PXAA("CATEGORY"))="" S $P(AFTER802,U,1)=""
E D
. S $P(AFTER802,U,1)=+$$PROVNARR^PXAPI(PXAA("CATEGORY"),9000010.07)
. I $P(AFTER802,U,1)'>0 D
.. D VAL802^PXAIPOVV,ERR^PXAI("CATEGORY",1)
.. S $P(AFTER802,U,1)=""
;
S $P(AFTER811,U,1)=$G(PXAA("COMMENT"))
;
I $G(PXAVISIT) D
.S VNODE=$G(^AUPNVSIT(PXAVISIT,0))
.D GETPATSA^PXSPECAUTH($P(VNODE,U,5),$P(VNODE,U),$P(VNODE,U,22),PXAVISIT,.TMPSA)
.S CODE="" F S CODE=$O(TMPSA(CODE)) Q:CODE="" D
..;not eligible
..I +$P(TMPSA(CODE),U)=0 K PXSAS(CODE) Q
..;eligible
..I +TMPSA(CODE)=1 I $G(PXSAS(CODE))'="",($G(PXSAS(CODE))<-1!(PXSAS(CODE)>1)) S PXSAS(CODE)=""
.D SETOLD800^PXSPECAUTH(.AFTER800,.PXSAS,1)
.D CONVERTTOPCE^PXSPECAUTH(.AFTER900,.PXSAS)
;
S $P(AFTER812,U,2)=$S($G(PXAA("PKG"))'="":PXAA("PKG"),1:$G(PXAPKG))
S $P(AFTER812,U,3)=$S($G(PXAA("SOURCE"))'="":PXAA("SOURCE"),1:$G(PXASOURC))
;
D PL^PXAIPL
;
;
SETPXKA ;--SET PXK ARRAY AFTER
S ^TMP("PXK",$J,"POV",PXAK,0,"AFTER")=$G(AFTER0)
S ^TMP("PXK",$J,"POV",PXAK,12,"AFTER")=$G(AFTER12)
S ^TMP("PXK",$J,"POV",PXAK,800,"AFTER")=$G(AFTER800)
S ^TMP("PXK",$J,"POV",PXAK,802,"AFTER")=$G(AFTER802)
S ^TMP("PXK",$J,"POV",PXAK,811,"AFTER")=$G(AFTER811)
S ^TMP("PXK",$J,"POV",PXAK,812,"AFTER")=$G(AFTER812)
M ^TMP("PXK",$J,"POV",PXAK,900,"AFTER")=AFTER900
;
SETVARB ;--SET VARIABLES BEFORE
;
;--GET IEN FOR 'PXK NODE'
D POV^PXBGPOV(PXAVISIT)
I $D(^TMP("PXBGPOVMATCH",$J,$G(PXAA("DIAGNOSIS")))) D
.S (^TMP("PXK",$J,"POV",PXAK,"IEN"),IENB)=$O(^TMP("PXBGPOVMATCH",$J,$G(PXAA("DIAGNOSIS")),0))
K ^TMP("PXBGPOVMATCH",$J)
;
BEFOR ;
I $G(IENB) D
.F PIECE=0,12,802,811,812 S ^TMP("PXK",$J,"POV",PXAK,PIECE,"BEFORE")=$G(^AUPNVPOV(IENB,PIECE))
.D GETSAFORVPOVDET^PXSPECAUTH(.BEFORE900,.BEFOR800,IENB)
E D
.S (BEFOR0,BEFOR12,BEFOR800,BEFOR802,BEFOR811,BEFOR812,BEFORE900)=""
.;
SETPXKB .;--SET PXK ARRAY BEFORE
.S ^TMP("PXK",$J,"POV",PXAK,0,"BEFORE")=$G(BEFOR0)
.S ^TMP("PXK",$J,"POV",PXAK,12,"BEFORE")=$G(BEFOR12)
.S ^TMP("PXK",$J,"POV",PXAK,800,"BEFORE")=$G(BEFOR800)
.S ^TMP("PXK",$J,"POV",PXAK,802,"BEFORE")=$G(BEFOR802)
.S ^TMP("PXK",$J,"POV",PXAK,811,"BEFORE")=$G(BEFOR811)
.S ^TMP("PXK",$J,"POV",PXAK,812,"BEFORE")=$G(BEFOR812)
.S ^TMP("PXK",$J,"POV",PXAK,800,"BEFORE")=BEFOR800
.M ^TMP("PXK",$J,"POV",PXAK,900,"BEFORE")=BEFORE900
.S ^TMP("PXK",$J,"POV",PXAK,"IEN")=""
;
;Package and Data Source cannot be edited.
S BEFOR812=^TMP("PXK",$J,"POV",PXAK,812,"BEFORE")
I BEFOR812'="" D
. I AFTER812=BEFOR812 Q
. I $P(BEFOR812,U,2)'="" S $P(AFTER812,U,2)=$P(BEFOR812,U,2)
. I $P(BEFOR812,U,3)'="" S $P(AFTER812,U,3)=$P(BEFOR812,U,3)
. S ^TMP("PXK",$J,"POV",PXAK,812,"AFTER")=AFTER812
;
MISC ;--MISCELLANEOUS NODE
;
Q
;
PRIM ;--SET A PROVIDER AS PRIMARY
;THIS IS NOT CALLED ANYMORE.
N PXBCNT,PXBKY,PXBSAM,PXBSKY,PRVDR,FPRI ;108
D PRV^PXBGPRV(PXAVISIT,.PXBSKY,.PXBKY,.PXBSAM,.PXBCNT,.PRVDR,.FPRI) ;108
I $D(PRVDR) Q
I '$D(PXBSKY) Q
;
S $P(AFTER0,U,1)=$P(^AUPNVPRV($O(PXBSKY(1,0)),0),U,1)
S $P(AFTER0,U,2)=$P(^AUPNVSIT(PXAVISIT,0),U,5)
S $P(AFTER0,U,3)=PXAVISIT
S $P(AFTER0,U,4)="P"
S ^TMP("PXK",$J,"PRV",22222,0,"AFTER")=AFTER0
S ^TMP("PXK",$J,"PRV",22222,0,"BEFORE")=$G(^AUPNVPRV($O(PXBSKY(1,0)),0))
S ^TMP("PXK",$J,"PRV",22222,"IEN")=$O(PXBSKY(1,0))
D EN1^PXKMAIN
K PXRDR
K ^TMP("PXBGPOVMATCH",$J)
Q
;
SPOVPRIM(PXADATA,VISITIEN,PXAERR) ;If there is an exisiting primary diagnosis
;change it to secondary so the new primary can be set.
N DIAG,IND,PDNEW
S IND=0,PDNEW=""
F S IND=+$O(@PXADATA@("DX/PL",IND)) Q:IND=0 D
. S DIAG=$G(@PXADATA@("DX/PL",IND,"DIAGNOSIS"))
. I DIAG="" Q
. I $G(@PXADATA@("DX/PL",IND,"PRIMARY"))=1 S PDNEW=DIAG
I PDNEW="" Q
;
;There is a new primary diagnosis, set any existing primary to
;secondary.
N FDA,IENS,MSG
S IND=0
F S IND=$O(^AUPNVPOV("AD",VISITIEN,IND)) Q:IND="" D
. I $P(^AUPNVPOV(IND,0),U,12)="P" D
.. S IENS=IND_","
.. S FDA(9000010.07,IENS,.12)="S"
.. D FILE^DIE("","FDA","MSG")
.. I $D(MSG) D Q
... S PXAERR(9)="V POV PRIMARY DIAGNOSIS CHANGE"
... S PXAERR(12)=MSG("DIERR",1,"TEXT",1)
... S PXAERR(13)="IENS="_IENS
... D ERRSET^PXAIPOVV
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXAIPOV 6252 printed Jul 11, 2026@02:22:17 Page 2
PXAIPOV ;ISL/JVS,PKR,ESW - SET THE DIAGNOSIS/PROBLEM LIST NODES ;Oct 29, 2025@14:09:42
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**28,73,69,108,112,130,124,174,168,203,199,211,228,244**;Aug 12, 1996;Build 37
+2 ;
+3 QUIT
POV ;--CREATE DIAGNOSIS
+1 ;
SET ;--SET AND NEW VARIABLES
+1 NEW AFTER0,AFTER12,AFTER800,AFTER801,AFTER802,AFTER811,AFTER812,AFTER8A
+2 NEW BEFOR0,BEFOR12,BEFOR800,BEFOR801,BEFOR802,BEFOR811,BEFOR812,BEFORE900,CODE,FPRI
+3 NEW EVENTDT,GMPSAVED,IENB,J,LNARR,NOPLLIST,PIECE,POVI,PRI,PRVDR,PXAA,PXAAX,PXAB,PXARRAY
+4 NEW PXAIVDT,PXBCNT,PXBCNTPL,PXBKY,PXBPMT,PXBSAM,PXBSKY,PXDIGNS,PXKDONE,PXSAS
+5 NEW STOP,SUB,VAR,VNODE,VSA,SAINPUTS,TMPSA
+6 ;
+7 KILL PXAERR
+8 SET PXAERR(8)=PXAK
+9 SET PXAERR(7)="DX/PL"
+10 ;
+11 SET SUB=""
FOR
SET SUB=$ORDER(@PXADATA@("DX/PL",PXAK,SUB))
if SUB=""
QUIT
Begin DoDot:1
+12 IF $PIECE(SUB," ")="PL"
SET CODE=$PIECE(SUB," ",2)
IF CODE'=""
IF $$FINDBYCODE^PXSPECAUTH(CODE)
SET PXSAS(CODE)=@PXADATA@("DX/PL",PXAK,SUB)
QUIT
+13 SET PXAA(SUB)=@PXADATA@("DX/PL",PXAK,SUB)
End DoDot:1
+14 ;
+15 ;--VALIDATE ENOUGH DATA
+16 DO VAL^PXAIPOVV
if $GET(STOP)=1
QUIT
+17 ;
SETVARA ;--SET VISIT VARIABLES
+1 SET $PIECE(AFTER0,U,1)=$GET(PXAA("DIAGNOSIS"))
+2 IF $GET(PXAA("DELETE"))
SET $PIECE(AFTER0,U,1)="@"
+3 SET $PIECE(AFTER0,U,2)=$GET(PATIENT)
SET PXAA("PATIENT")=$GET(PATIENT)
+4 SET $PIECE(AFTER0,U,3)=$GET(PXAVISIT)
+5 ;If Provider Narrative is not passed it is generated in VAL^PXAIPOVV.
+6 SET $PIECE(AFTER0,U,4)=+$$PROVNARR^PXAPI($GET(PXAA("NARRATIVE")),9000010.07)
+7 IF $PIECE(AFTER0,U,4)'>0
DO VAL04^PXAIPOVV
DO ERR^PXAI("NARRATIVE",1)
if $DATA(STOP)
QUIT
+8 ;PX*1*124
+9 SET PRI=$GET(PXAA("PRIMARY"))
+10 SET $PIECE(AFTER0,U,12)=$SELECT(PRI=1:"P",PRI="P":"P",1:"S")
+11 ;--ADDED FOR PATCH 28
+12 SET $PIECE(AFTER0,U,15)=$GET(PXAA("LEXICON TERM"))
+13 SET $PIECE(AFTER0,U,16)=$GET(PXAA("PL IEN"))
+14 SET $PIECE(AFTER0,U,17)=$GET(PXAA("ORD/RES"))
+15 ;--END OF NEW PATCH 28
+16 SET $PIECE(AFTER12,U,1)=$GET(PXAA("EVENT D/T"))
+17 SET $PIECE(AFTER12,U,2)=$GET(PXAA("ORD PROVIDER"))
+18 SET $PIECE(AFTER12,U,4)=$GET(PXAA("ENC PROVIDER"))
+19 ;PX*1*108
+20 IF $GET(PXAA("ENC PROVIDER"))]""
IF '$GET(PXAA("DELETE"))
Begin DoDot:1
+21 SET ^TMP("PXAIADDPRV",$JOB,$GET(PXAA("ENC PROVIDER")))="ENC"
End DoDot:1
+22 IF $GET(PXAA("ORD PROVIDER"))]""
IF '$GET(PXAA("DELETE"))
Begin DoDot:1
+23 SET ^TMP("PXAIADDPRV",$JOB,$GET(PXAA("ORD PROVIDER")))="ORD"
End DoDot:1
+24 ;
+25 IF $GET(PXAA("CATEGORY"))=""
SET $PIECE(AFTER802,U,1)=""
+26 IF '$TEST
Begin DoDot:1
+27 SET $PIECE(AFTER802,U,1)=+$$PROVNARR^PXAPI(PXAA("CATEGORY"),9000010.07)
+28 IF $PIECE(AFTER802,U,1)'>0
Begin DoDot:2
+29 DO VAL802^PXAIPOVV
DO ERR^PXAI("CATEGORY",1)
+30 SET $PIECE(AFTER802,U,1)=""
End DoDot:2
End DoDot:1
+31 ;
+32 SET $PIECE(AFTER811,U,1)=$GET(PXAA("COMMENT"))
+33 ;
+34 IF $GET(PXAVISIT)
Begin DoDot:1
+35 SET VNODE=$GET(^AUPNVSIT(PXAVISIT,0))
+36 DO GETPATSA^PXSPECAUTH($PIECE(VNODE,U,5),$PIECE(VNODE,U),$PIECE(VNODE,U,22),PXAVISIT,.TMPSA)
+37 SET CODE=""
FOR
SET CODE=$ORDER(TMPSA(CODE))
if CODE=""
QUIT
Begin DoDot:2
+38 ;not eligible
+39 IF +$PIECE(TMPSA(CODE),U)=0
KILL PXSAS(CODE)
QUIT
+40 ;eligible
+41 IF +TMPSA(CODE)=1
IF $GET(PXSAS(CODE))'=""
IF ($GET(PXSAS(CODE))<-1!(PXSAS(CODE)>1))
SET PXSAS(CODE)=""
End DoDot:2
+42 DO SETOLD800^PXSPECAUTH(.AFTER800,.PXSAS,1)
+43 DO CONVERTTOPCE^PXSPECAUTH(.AFTER900,.PXSAS)
End DoDot:1
+44 ;
+45 SET $PIECE(AFTER812,U,2)=$SELECT($GET(PXAA("PKG"))'="":PXAA("PKG"),1:$GET(PXAPKG))
+46 SET $PIECE(AFTER812,U,3)=$SELECT($GET(PXAA("SOURCE"))'="":PXAA("SOURCE"),1:$GET(PXASOURC))
+47 ;
+48 DO PL^PXAIPL
+49 ;
+50 ;
SETPXKA ;--SET PXK ARRAY AFTER
+1 SET ^TMP("PXK",$JOB,"POV",PXAK,0,"AFTER")=$GET(AFTER0)
+2 SET ^TMP("PXK",$JOB,"POV",PXAK,12,"AFTER")=$GET(AFTER12)
+3 SET ^TMP("PXK",$JOB,"POV",PXAK,800,"AFTER")=$GET(AFTER800)
+4 SET ^TMP("PXK",$JOB,"POV",PXAK,802,"AFTER")=$GET(AFTER802)
+5 SET ^TMP("PXK",$JOB,"POV",PXAK,811,"AFTER")=$GET(AFTER811)
+6 SET ^TMP("PXK",$JOB,"POV",PXAK,812,"AFTER")=$GET(AFTER812)
+7 MERGE ^TMP("PXK",$JOB,"POV",PXAK,900,"AFTER")=AFTER900
+8 ;
SETVARB ;--SET VARIABLES BEFORE
+1 ;
+2 ;--GET IEN FOR 'PXK NODE'
+3 DO POV^PXBGPOV(PXAVISIT)
+4 IF $DATA(^TMP("PXBGPOVMATCH",$JOB,$GET(PXAA("DIAGNOSIS"))))
Begin DoDot:1
+5 SET (^TMP("PXK",$JOB,"POV",PXAK,"IEN"),IENB)=$ORDER(^TMP("PXBGPOVMATCH",$JOB,$GET(PXAA("DIAGNOSIS")),0))
End DoDot:1
+6 KILL ^TMP("PXBGPOVMATCH",$JOB)
+7 ;
BEFOR ;
+1 IF $GET(IENB)
Begin DoDot:1
+2 FOR PIECE=0,12,802,811,812
SET ^TMP("PXK",$JOB,"POV",PXAK,PIECE,"BEFORE")=$GET(^AUPNVPOV(IENB,PIECE))
+3 DO GETSAFORVPOVDET^PXSPECAUTH(.BEFORE900,.BEFOR800,IENB)
End DoDot:1
+4 IF '$TEST
Begin DoDot:1
+5 SET (BEFOR0,BEFOR12,BEFOR800,BEFOR802,BEFOR811,BEFOR812,BEFORE900)=""
+6 ;
SETPXKB ;--SET PXK ARRAY BEFORE
+1 SET ^TMP("PXK",$JOB,"POV",PXAK,0,"BEFORE")=$GET(BEFOR0)
+2 SET ^TMP("PXK",$JOB,"POV",PXAK,12,"BEFORE")=$GET(BEFOR12)
+3 SET ^TMP("PXK",$JOB,"POV",PXAK,800,"BEFORE")=$GET(BEFOR800)
+4 SET ^TMP("PXK",$JOB,"POV",PXAK,802,"BEFORE")=$GET(BEFOR802)
+5 SET ^TMP("PXK",$JOB,"POV",PXAK,811,"BEFORE")=$GET(BEFOR811)
+6 SET ^TMP("PXK",$JOB,"POV",PXAK,812,"BEFORE")=$GET(BEFOR812)
+7 SET ^TMP("PXK",$JOB,"POV",PXAK,800,"BEFORE")=BEFOR800
+8 MERGE ^TMP("PXK",$JOB,"POV",PXAK,900,"BEFORE")=BEFORE900
+9 SET ^TMP("PXK",$JOB,"POV",PXAK,"IEN")=""
End DoDot:1
+10 ;
+11 ;Package and Data Source cannot be edited.
+12 SET BEFOR812=^TMP("PXK",$JOB,"POV",PXAK,812,"BEFORE")
+13 IF BEFOR812'=""
Begin DoDot:1
+14 IF AFTER812=BEFOR812
QUIT
+15 IF $PIECE(BEFOR812,U,2)'=""
SET $PIECE(AFTER812,U,2)=$PIECE(BEFOR812,U,2)
+16 IF $PIECE(BEFOR812,U,3)'=""
SET $PIECE(AFTER812,U,3)=$PIECE(BEFOR812,U,3)
+17 SET ^TMP("PXK",$JOB,"POV",PXAK,812,"AFTER")=AFTER812
End DoDot:1
+18 ;
MISC ;--MISCELLANEOUS NODE
+1 ;
+2 QUIT
+3 ;
PRIM ;--SET A PROVIDER AS PRIMARY
+1 ;THIS IS NOT CALLED ANYMORE.
+2 ;108
NEW PXBCNT,PXBKY,PXBSAM,PXBSKY,PRVDR,FPRI
+3 ;108
DO PRV^PXBGPRV(PXAVISIT,.PXBSKY,.PXBKY,.PXBSAM,.PXBCNT,.PRVDR,.FPRI)
+4 IF $DATA(PRVDR)
QUIT
+5 IF '$DATA(PXBSKY)
QUIT
+6 ;
+7 SET $PIECE(AFTER0,U,1)=$PIECE(^AUPNVPRV($ORDER(PXBSKY(1,0)),0),U,1)
+8 SET $PIECE(AFTER0,U,2)=$PIECE(^AUPNVSIT(PXAVISIT,0),U,5)
+9 SET $PIECE(AFTER0,U,3)=PXAVISIT
+10 SET $PIECE(AFTER0,U,4)="P"
+11 SET ^TMP("PXK",$JOB,"PRV",22222,0,"AFTER")=AFTER0
+12 SET ^TMP("PXK",$JOB,"PRV",22222,0,"BEFORE")=$GET(^AUPNVPRV($ORDER(PXBSKY(1,0)),0))
+13 SET ^TMP("PXK",$JOB,"PRV",22222,"IEN")=$ORDER(PXBSKY(1,0))
+14 DO EN1^PXKMAIN
+15 KILL PXRDR
+16 KILL ^TMP("PXBGPOVMATCH",$JOB)
+17 QUIT
+18 ;
SPOVPRIM(PXADATA,VISITIEN,PXAERR) ;If there is an exisiting primary diagnosis
+1 ;change it to secondary so the new primary can be set.
+2 NEW DIAG,IND,PDNEW
+3 SET IND=0
SET PDNEW=""
+4 FOR
SET IND=+$ORDER(@PXADATA@("DX/PL",IND))
if IND=0
QUIT
Begin DoDot:1
+5 SET DIAG=$GET(@PXADATA@("DX/PL",IND,"DIAGNOSIS"))
+6 IF DIAG=""
QUIT
+7 IF $GET(@PXADATA@("DX/PL",IND,"PRIMARY"))=1
SET PDNEW=DIAG
End DoDot:1
+8 IF PDNEW=""
QUIT
+9 ;
+10 ;There is a new primary diagnosis, set any existing primary to
+11 ;secondary.
+12 NEW FDA,IENS,MSG
+13 SET IND=0
+14 FOR
SET IND=$ORDER(^AUPNVPOV("AD",VISITIEN,IND))
if IND=""
QUIT
Begin DoDot:1
+15 IF $PIECE(^AUPNVPOV(IND,0),U,12)="P"
Begin DoDot:2
+16 SET IENS=IND_","
+17 SET FDA(9000010.07,IENS,.12)="S"
+18 DO FILE^DIE("","FDA","MSG")
+19 IF $DATA(MSG)
Begin DoDot:3
+20 SET PXAERR(9)="V POV PRIMARY DIAGNOSIS CHANGE"
+21 SET PXAERR(12)=MSG("DIERR",1,"TEXT",1)
+22 SET PXAERR(13)="IENS="_IENS
+23 DO ERRSET^PXAIPOVV
End DoDot:3
QUIT
End DoDot:2
End DoDot:1
+24 QUIT
+25 ;
