Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXBGPOV

PXBGPOV.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. POV(VISIT) ;--Gather the entries in the V POV file
  1. ;
  1. N DA,DIC,DIQ,DR,GROUP,I,IEN,PKG,POV,POVI,PRIM,PROBLEM,PROVIDER
  1. N PXBC,PXBPL,PXBPLA,PXBREQ,PXCI,PXDXDATE,QUANTITY,SNARR,SOURC
  1. ;
  1. K ^TMP("PXBU",$J),POV,PXBKY,PXBSAM,PXBSKY,PXDIGNS,NOPLLIST
  1. K ^UTILITY("DIQ1",$J)
  1. S FPRI="",PROBLEM=""
  1. I $D(^AUPNVPOV("AD",VISIT)) D
  1. .S IEN=0 F S IEN=$O(^AUPNVPOV("AD",VISIT,IEN)) Q:IEN'>0 D
  1. ..S ^TMP("PXBU",$J,"POV",IEN)=""
  1. ;
  1. A ;--Set array with DIAGNOSIS codes
  1. ;
  1. D PL^PXBGPL(PATIENT)
  1. I $D(^TMP("PXBU",$J,"POV")) D
  1. .S IEN=0 F S IEN=$O(^TMP("PXBU",$J,"POV",IEN)) Q:IEN'>0 D
  1. ..S DIC=9000010.07,DR=".01;1204;.04;.12;.17;81202;81203;80001:80008",DA=IEN,DIQ(0)="IE" D EN^DIQ1
  1. ..S PROVIDER=$G(^UTILITY("DIQ1",$J,9000010.07,DA,"1204","E"))
  1. ..S LNARR=$G(^UTILITY("DIQ1",$J,9000010.07,DA,".04","E"))
  1. ..S POV=$G(^UTILITY("DIQ1",$J,9000010.07,DA,".01","E"))
  1. ..S PROBLEM="" S:$D(^TMP("PXBKYPL",$J,POV)) PROBLEM="YES"
  1. ..S POVI=$G(^UTILITY("DIQ1",$J,9000010.07,DA,".01","I"))
  1. ..S PRIM=$G(^UTILITY("DIQ1",$J,9000010.07,DA,".12","E"))
  1. ..S ORDER=$G(^UTILITY("DIQ1",$J,9000010.07,DA,".17","E"))
  1. ..S PKG=$G(^UTILITY("DIQ1",$J,9000010.07,DA,"81202","I"))
  1. ..I PKG']"" S PKG="NONE"
  1. ..S SOURC=$G(^UTILITY("DIQ1",$J,9000010.07,DA,"81203","I"))
  1. ..I SOURC']"" S SOURC="NONE"
  1. ..S PXDXDATE=$$CSDATE^PXDXUTL(VISIT)
  1. ..S SNARR=$P($$ICDDATA^ICDXCODE("DIAG",POVI,PXDXDATE,"I"),U,4)
  1. ..I $L(LNARR)'>30 S LNARR=$$DXNARR^PXUTL1(POVI,PXDXDATE)
  1. ..S FPRI=FPRI_$E(PRIM,1,3) ;--Creating flag for Primary prompt
  1. ..S GROUP=POV_"^"_PROVIDER_"^"_SNARR_"^"_PRIM_"^"_PROBLEM_"^"_LNARR_"^"_ORDER
  1. ..; 1 2 3 4 5 6 7
  1. ..I PRIM["PRI" S PXDIGNS("PRIMARY")=POV
  1. ..S ^TMP("PXBPOV",$J,POV,IEN)=GROUP
  1. ..S ^TMP("PXBGPOVMATCH",$J,POVI,IEN)=""
  1. ..I $P(GROUP,"^",5)'["YES" S NOPLLIST=1
  1. ..S GROUP=$G(^UTILITY("DIQ1",$J,9000010.07,IEN,80001,"I"))
  1. ..F I=2:1:8 S GROUP=GROUP_U_$G(^UTILITY("DIQ1",$J,9000010.07,IEN,80000+I,"I"))
  1. ..S PXCI(IEN)=GROUP,PXBREQ(POVI,"I")=GROUP
  1. ;
  1. B ;--Add line numbers
  1. ;
  1. I $D(^TMP("PXBPOV",$J)) D
  1. .S PXBC=0,POV="" F S POV=$O(^TMP("PXBPOV",$J,POV)) Q:POV="" Q:PXBC>40 D
  1. ..S IEN=0 F S IEN=$O(^TMP("PXBPOV",$J,POV,IEN)) Q:IEN="" S PXBC=PXBC+1 D
  1. ...S PXBKY(POV,PXBC)=$G(^TMP("PXBPOV",$J,POV,IEN)),PXBSAM(PXBC)=$G(^TMP("PXBPOV",$J,POV,IEN))
  1. ...S PXBSKY(PXBC,IEN)=""
  1. ...S PXBSAM(PXBC,"LNARR")=$P(PXBSAM(PXBC),U,6)
  1. ...S PXBSAM(PXBC,"I")=PXCI(IEN)
  1. FINISG ;--finish up some variables
  1. ;--FPRI=0 NO PRIMARY
  1. S:FPRI'["PRI" FPRI=0 S:FPRI["PRI" FPRI=1
  1. EXIT ;--KILL
  1. K ^TMP("PXBU",$J),^TMP("PXBKYPL",$J),^TMP("PXBSAMPL",$J),PXBSKYPL
  1. K ^TMP("PXBPOV",$J),^UTILITY("DIQ1",$J)
  1. S PXBCNT=+$G(PXBC)
  1. Q
  1. ;
  1. XLATE(VST,DX) ;Translate DX into POV from VST
  1. Q:'$G(VST)!'$G(DX) "" Q:'$D(^AUPNVPOV("AD",VST)) ""
  1. S DX=+$$ICDDATA^ICDXCODE("DIAG",DX,$$CSDATE^PXDXUTL(VST),"I") Q:DX<0 ""
  1. N IEN,ANS,VAL S (IEN,ANS,VAL)=""
  1. F Q:ANS D
  1. .S IEN=$O(^AUPNVPOV("AD",VST,IEN)) I 'IEN S ANS=1 Q
  1. .S VAL=$G(^AUPNVPOV(IEN,0)),ANS=($P(VAL,U)=DX)
  1. S ANS=IEN_U_DX_U_$P(VAL,U,12) S:IEN ANS=ANS_U_$G(^AUPNVPOV(IEN,800))
  1. Q ANS
  1. ;