- 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 Feb 18, 2025@23:52:56 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 ;