PXBGPOV ;ISL/JVS,ESW - GATHER POV (DIAGNOSIS) ;11/21/2019
;;1.0;PCE PATIENT CARE ENCOUNTER;**11,112,149,124,168,199,211**;Aug 12, 1996;Build 454
;
POV(VISIT) ;--Gather the entries in the V POV file
;
N DA,DIC,DIQ,DR,GROUP,I,IEN,PKG,POV,POVI,PRIM,PROBLEM,PROVIDER
N PXBC,PXBPL,PXBPLA,PXBREQ,PXCI,PXDXDATE,QUANTITY,SNARR,SOURC
;
K ^TMP("PXBU",$J),POV,PXBKY,PXBSAM,PXBSKY,PXDIGNS,NOPLLIST
K ^UTILITY("DIQ1",$J)
S FPRI="",PROBLEM=""
I $D(^AUPNVPOV("AD",VISIT)) D
.S IEN=0 F S IEN=$O(^AUPNVPOV("AD",VISIT,IEN)) Q:IEN'>0 D
..S ^TMP("PXBU",$J,"POV",IEN)=""
;
A ;--Set array with DIAGNOSIS codes
;
D PL^PXBGPL(PATIENT)
I $D(^TMP("PXBU",$J,"POV")) D
.S IEN=0 F S IEN=$O(^TMP("PXBU",$J,"POV",IEN)) Q:IEN'>0 D
..S DIC=9000010.07,DR=".01;1204;.04;.12;.17;81202;81203;80001:80008",DA=IEN,DIQ(0)="IE" D EN^DIQ1
..S PROVIDER=$G(^UTILITY("DIQ1",$J,9000010.07,DA,"1204","E"))
..S LNARR=$G(^UTILITY("DIQ1",$J,9000010.07,DA,".04","E"))
..S POV=$G(^UTILITY("DIQ1",$J,9000010.07,DA,".01","E"))
..S PROBLEM="" S:$D(^TMP("PXBKYPL",$J,POV)) PROBLEM="YES"
..S POVI=$G(^UTILITY("DIQ1",$J,9000010.07,DA,".01","I"))
..S PRIM=$G(^UTILITY("DIQ1",$J,9000010.07,DA,".12","E"))
..S ORDER=$G(^UTILITY("DIQ1",$J,9000010.07,DA,".17","E"))
..S PKG=$G(^UTILITY("DIQ1",$J,9000010.07,DA,"81202","I"))
..I PKG']"" S PKG="NONE"
..S SOURC=$G(^UTILITY("DIQ1",$J,9000010.07,DA,"81203","I"))
..I SOURC']"" S SOURC="NONE"
..S PXDXDATE=$$CSDATE^PXDXUTL(VISIT)
..S SNARR=$P($$ICDDATA^ICDXCODE("DIAG",POVI,PXDXDATE,"I"),U,4)
..I $L(LNARR)'>30 S LNARR=$$DXNARR^PXUTL1(POVI,PXDXDATE)
..S FPRI=FPRI_$E(PRIM,1,3) ;--Creating flag for Primary prompt
..S GROUP=POV_"^"_PROVIDER_"^"_SNARR_"^"_PRIM_"^"_PROBLEM_"^"_LNARR_"^"_ORDER
..; 1 2 3 4 5 6 7
..I PRIM["PRI" S PXDIGNS("PRIMARY")=POV
..S ^TMP("PXBPOV",$J,POV,IEN)=GROUP
..S ^TMP("PXBGPOVMATCH",$J,POVI,IEN)=""
..I $P(GROUP,"^",5)'["YES" S NOPLLIST=1
..S GROUP=$G(^UTILITY("DIQ1",$J,9000010.07,IEN,80001,"I"))
..F I=2:1:8 S GROUP=GROUP_U_$G(^UTILITY("DIQ1",$J,9000010.07,IEN,80000+I,"I"))
..S PXCI(IEN)=GROUP,PXBREQ(POVI,"I")=GROUP
;
B ;--Add line numbers
;
I $D(^TMP("PXBPOV",$J)) D
.S PXBC=0,POV="" F S POV=$O(^TMP("PXBPOV",$J,POV)) Q:POV="" Q:PXBC>40 D
..S IEN=0 F S IEN=$O(^TMP("PXBPOV",$J,POV,IEN)) Q:IEN="" S PXBC=PXBC+1 D
...S PXBKY(POV,PXBC)=$G(^TMP("PXBPOV",$J,POV,IEN)),PXBSAM(PXBC)=$G(^TMP("PXBPOV",$J,POV,IEN))
...S PXBSKY(PXBC,IEN)=""
...S PXBSAM(PXBC,"LNARR")=$P(PXBSAM(PXBC),U,6)
...S PXBSAM(PXBC,"I")=PXCI(IEN)
FINISG ;--finish up some variables
;--FPRI=0 NO PRIMARY
S:FPRI'["PRI" FPRI=0 S:FPRI["PRI" FPRI=1
EXIT ;--KILL
K ^TMP("PXBU",$J),^TMP("PXBKYPL",$J),^TMP("PXBSAMPL",$J),PXBSKYPL
K ^TMP("PXBPOV",$J),^UTILITY("DIQ1",$J)
S PXBCNT=+$G(PXBC)
Q
;
XLATE(VST,DX) ;Translate DX into POV from VST
Q:'$G(VST)!'$G(DX) "" Q:'$D(^AUPNVPOV("AD",VST)) ""
S DX=+$$ICDDATA^ICDXCODE("DIAG",DX,$$CSDATE^PXDXUTL(VST),"I") Q:DX<0 ""
N IEN,ANS,VAL S (IEN,ANS,VAL)=""
F Q:ANS D
.S IEN=$O(^AUPNVPOV("AD",VST,IEN)) I 'IEN S ANS=1 Q
.S VAL=$G(^AUPNVPOV(IEN,0)),ANS=($P(VAL,U)=DX)
S ANS=IEN_U_DX_U_$P(VAL,U,12) S:IEN ANS=ANS_U_$G(^AUPNVPOV(IEN,800))
Q ANS
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXBGPOV 3262 printed Oct 16, 2024@18:27:21 Page 2
PXBGPOV ;ISL/JVS,ESW - GATHER POV (DIAGNOSIS) ;11/21/2019
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,112,149,124,168,199,211**;Aug 12, 1996;Build 454
+2 ;
POV(VISIT) ;--Gather the entries in the V POV file
+1 ;
+2 NEW DA,DIC,DIQ,DR,GROUP,I,IEN,PKG,POV,POVI,PRIM,PROBLEM,PROVIDER
+3 NEW PXBC,PXBPL,PXBPLA,PXBREQ,PXCI,PXDXDATE,QUANTITY,SNARR,SOURC
+4 ;
+5 KILL ^TMP("PXBU",$JOB),POV,PXBKY,PXBSAM,PXBSKY,PXDIGNS,NOPLLIST
+6 KILL ^UTILITY("DIQ1",$JOB)
+7 SET FPRI=""
SET PROBLEM=""
+8 IF $DATA(^AUPNVPOV("AD",VISIT))
Begin DoDot:1
+9 SET IEN=0
FOR
SET IEN=$ORDER(^AUPNVPOV("AD",VISIT,IEN))
if IEN'>0
QUIT
Begin DoDot:2
+10 SET ^TMP("PXBU",$JOB,"POV",IEN)=""
End DoDot:2
End DoDot:1
+11 ;
A ;--Set array with DIAGNOSIS codes
+1 ;
+2 DO PL^PXBGPL(PATIENT)
+3 IF $DATA(^TMP("PXBU",$JOB,"POV"))
Begin DoDot:1
+4 SET IEN=0
FOR
SET IEN=$ORDER(^TMP("PXBU",$JOB,"POV",IEN))
if IEN'>0
QUIT
Begin DoDot:2
+5 SET DIC=9000010.07
SET DR=".01;1204;.04;.12;.17;81202;81203;80001:80008"
SET DA=IEN
SET DIQ(0)="IE"
DO EN^DIQ1
+6 SET PROVIDER=$GET(^UTILITY("DIQ1",$JOB,9000010.07,DA,"1204","E"))
+7 SET LNARR=$GET(^UTILITY("DIQ1",$JOB,9000010.07,DA,".04","E"))
+8 SET POV=$GET(^UTILITY("DIQ1",$JOB,9000010.07,DA,".01","E"))
+9 SET PROBLEM=""
if $DATA(^TMP("PXBKYPL",$JOB,POV))
SET PROBLEM="YES"
+10 SET POVI=$GET(^UTILITY("DIQ1",$JOB,9000010.07,DA,".01","I"))
+11 SET PRIM=$GET(^UTILITY("DIQ1",$JOB,9000010.07,DA,".12","E"))
+12 SET ORDER=$GET(^UTILITY("DIQ1",$JOB,9000010.07,DA,".17","E"))
+13 SET PKG=$GET(^UTILITY("DIQ1",$JOB,9000010.07,DA,"81202","I"))
+14 IF PKG']""
SET PKG="NONE"
+15 SET SOURC=$GET(^UTILITY("DIQ1",$JOB,9000010.07,DA,"81203","I"))
+16 IF SOURC']""
SET SOURC="NONE"
+17 SET PXDXDATE=$$CSDATE^PXDXUTL(VISIT)
+18 SET SNARR=$PIECE($$ICDDATA^ICDXCODE("DIAG",POVI,PXDXDATE,"I"),U,4)
+19 IF $LENGTH(LNARR)'>30
SET LNARR=$$DXNARR^PXUTL1(POVI,PXDXDATE)
+20 ;--Creating flag for Primary prompt
SET FPRI=FPRI_$EXTRACT(PRIM,1,3)
+21 SET GROUP=POV_"^"_PROVIDER_"^"_SNARR_"^"_PRIM_"^"_PROBLEM_"^"_LNARR_"^"_ORDER
+22 ; 1 2 3 4 5 6 7
+23 IF PRIM["PRI"
SET PXDIGNS("PRIMARY")=POV
+24 SET ^TMP("PXBPOV",$JOB,POV,IEN)=GROUP
+25 SET ^TMP("PXBGPOVMATCH",$JOB,POVI,IEN)=""
+26 IF $PIECE(GROUP,"^",5)'["YES"
SET NOPLLIST=1
+27 SET GROUP=$GET(^UTILITY("DIQ1",$JOB,9000010.07,IEN,80001,"I"))
+28 FOR I=2:1:8
SET GROUP=GROUP_U_$GET(^UTILITY("DIQ1",$JOB,9000010.07,IEN,80000+I,"I"))
+29 SET PXCI(IEN)=GROUP
SET PXBREQ(POVI,"I")=GROUP
End DoDot:2
End DoDot:1
+30 ;
B ;--Add line numbers
+1 ;
+2 IF $DATA(^TMP("PXBPOV",$JOB))
Begin DoDot:1
+3 SET PXBC=0
SET POV=""
FOR
SET POV=$ORDER(^TMP("PXBPOV",$JOB,POV))
if POV=""
QUIT
if PXBC>40
QUIT
Begin DoDot:2
+4 SET IEN=0
FOR
SET IEN=$ORDER(^TMP("PXBPOV",$JOB,POV,IEN))
if IEN=""
QUIT
SET PXBC=PXBC+1
Begin DoDot:3
+5 SET PXBKY(POV,PXBC)=$GET(^TMP("PXBPOV",$JOB,POV,IEN))
SET PXBSAM(PXBC)=$GET(^TMP("PXBPOV",$JOB,POV,IEN))
+6 SET PXBSKY(PXBC,IEN)=""
+7 SET PXBSAM(PXBC,"LNARR")=$PIECE(PXBSAM(PXBC),U,6)
+8 SET PXBSAM(PXBC,"I")=PXCI(IEN)
End DoDot:3
End DoDot:2
End DoDot:1
FINISG ;--finish up some variables
+1 ;--FPRI=0 NO PRIMARY
+2 if FPRI'["PRI"
SET FPRI=0
if FPRI["PRI"
SET FPRI=1
EXIT ;--KILL
+1 KILL ^TMP("PXBU",$JOB),^TMP("PXBKYPL",$JOB),^TMP("PXBSAMPL",$JOB),PXBSKYPL
+2 KILL ^TMP("PXBPOV",$JOB),^UTILITY("DIQ1",$JOB)
+3 SET PXBCNT=+$GET(PXBC)
+4 QUIT
+5 ;
XLATE(VST,DX) ;Translate DX into POV from VST
+1 if '$GET(VST)!'$GET(DX)
QUIT ""
if '$DATA(^AUPNVPOV("AD",VST))
QUIT ""
+2 SET DX=+$$ICDDATA^ICDXCODE("DIAG",DX,$$CSDATE^PXDXUTL(VST),"I")
if DX<0
QUIT ""
+3 NEW IEN,ANS,VAL
SET (IEN,ANS,VAL)=""
+4 FOR
if ANS
QUIT
Begin DoDot:1
+5 SET IEN=$ORDER(^AUPNVPOV("AD",VST,IEN))
IF 'IEN
SET ANS=1
QUIT
+6 SET VAL=$GET(^AUPNVPOV(IEN,0))
SET ANS=($PIECE(VAL,U)=DX)
End DoDot:1
+7 SET ANS=IEN_U_DX_U_$PIECE(VAL,U,12)
if IEN
SET ANS=ANS_U_$GET(^AUPNVPOV(IEN,800))
+8 QUIT ANS
+9 ;
