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

VPRSDAVF.m

Go to the documentation of this file. 
  1. VPRSDAVF ;SLC/MKB -- SDA Vfile utilities ;7/29/22  14:11
  1.  ;;1.0;VIRTUAL PATIENT RECORD;**30**;Sep 01, 2011;Build 9
  1.  ;;Per VHA Directive 6402, this routine should not be modified.
  1.  ;
  1.  ; External References          DBIA#
  1.  ; -------------------          -----
  1.  ; ^AUPNVSIT                     2028
  1.  ; ^AUTTHF                       4295
  1.  ; ^DIC(9.4                     10048
  1.  ; ^EDP(230                      7180
  1.  ; ^PXRMINDX                     4290
  1.  ; DILFD                         2055
  1.  ; DIQ                           2056
  1.  ; PXPXRM                        4250
  1.  ;
  1.  ;
  1.  ; Queries called from GET^DDE, returns DLIST(#)=ien
  1.  ; Expects context variables DFN, DSTRT, DSTOP, DMAX
  1.  ;
  1. EXAMS ; -- V Exams (Physical Exams)
  1.  N FNUM S FNUM=9000010.13 G PXRM
  1.  ;
  1. HFACTORS ; -- V Health Factors (Health Concerns)
  1.  N FNUM S FNUM=9000010.23 G PXRM
  1.  ;
  1. CPT ; -- V CPT (Procedures)
  1.  N FNUM S FNUM=9000010.18 G PXRM
  1.  ;
  1. POV ; -- V POV (Diagnosis)
  1.  N FNUM S FNUM=9000010.07 G PXRM
  1.  ;
  1. IMMS ; -- V Immunizations
  1.  N FNUM S FNUM=9000010.11 G PXRM
  1.  ;
  1. PXRM ; -- Search PXRM index
  1.  N VPRSTART,VPRSTOP,VPRIDT,VPRN,ID
  1.  S VPRSTART=DSTRT,VPRSTOP=DSTOP,VPRN=0
  1.  D SORT^VPRDJ09 ;sort ^PXRMINDX into ^TMP("VPRPX",$J,IDT)
  1.  S VPRIDT=0 F  S VPRIDT=$O(^TMP("VPRPX",$J,VPRIDT)) Q:VPRIDT<1  D  Q:VPRN'<DMAX
  1.  . S ID=0 F  S ID=$O(^TMP("VPRPX",$J,VPRIDT,ID)) Q:ID<1  D  Q:VPRN'<DMAX
  1.  .. I FNUM=9000010.18,'$$VCPT(ID) Q
  1.  .. S VPRN=VPRN+1,DLIST(VPRN)=ID
  1.  K ^TMP("VPRPX",$J)
  1.  Q
  1.  ;
  1. ICR ; -- V Imm Contraindications/Refusals [query]
  1.  N ROOT,INDX,DATE,IDT,DA,TMP,VPRN S VPRN=0
  1.  ; find records in ^PXRMINDX, sort by date
  1.  S ROOT="^PXRMINDX(9000010.707,""PCI"","_DFN,INDX=ROOT_")",ROOT=ROOT_","
  1.  F  S INDX=$Q(@INDX) Q:INDX'[ROOT  D
  1.  . S DATE=$QS(INDX,6) Q:DATE<DSTRT  Q:DATE>DSTOP
  1.  . S DA=$QS(INDX,8),IDT=9999999-DATE,TMP(IDT,DA)=""
  1.  ; return [DMAX] entries
  1.  S IDT=0 F  S IDT=$O(TMP(IDT)) Q:IDT<1  D  Q:VPRN'<DMAX
  1.  . S DA=0 F  S DA=$O(TMP(IDT,DA)) Q:DA<1  S VPRN=VPRN+1,DLIST(VPRN)=DA
  1.  Q
  1.  ;
  1. HFCVR ; -- V Health Factors, for COVID Vaccination Refusal [query]
  1.  N ITEM,NAME,DATE,DA,X,VPRN S VPRN=0
  1.  S ITEM=+$O(^AUTTHF("B","VA-SARS-COV-2 VACCINE REFUSAL",0)) Q:ITEM<1  D CVR
  1.  S NAME="VA-SARS-COV-2 IMM REFUSAL"
  1.  F  S NAME=$O(^AUTTHF("B",NAME)) Q:NAME'?1"VA-SARS-COV-2 IMM REFUSAL".E  S ITEM=+$O(^(NAME,0)) D CVR
  1.  Q
  1. CVR ;loop for ITEM
  1.  S DATE=DSTRT F  S DATE=$O(^PXRMINDX(9000010.23,"PI",+$G(DFN),ITEM,DATE)) Q:DATE<1!(DATE>DSTOP)  D  Q:VPRN'<DMAX
  1.  . S DA=0 F  S DA=$O(^PXRMINDX(9000010.23,"PI",+$G(DFN),ITEM,DATE,DA)) Q:DA<1  S VPRN=VPRN+1,DLIST(VPRN)=DA Q:VPRN'<DMAX
  1.  Q
  1.  ;
  1.  ;
  1. XAM1 ; -- get info for single XAM record [ID Action]
  1.  ; Expects/updates DIEN = #9000010.13 ien
  1.  ;       Returns VPRVST = #9000010 ien
  1.  ;              VPRVST0 = Visit zero node
  1.  ;                VPRXM array
  1.  K VPRXM D:$$ZERO^VPRENC("XAM",+DIEN) VXAM^PXPXRM(+DIEN,.VPRXM)
  1.  S VPRVST=$G(VPRXM("VISIT")),VPRVST0=$G(^AUPNVSIT(+VPRVST,0))
  1.  S VPRXM=DIEN,DIEN=+DIEN
  1.  Q
  1.  ;
  1. HF1 ; -- get info for single HF record [ID Action]
  1.  ; Expects/updates DIEN = #9000010.23 ien
  1.  ;       Returns VPRVST = #9000010 ien
  1.  ;              VPRVST0 = Visit zero node
  1.  ;                VPRHF array
  1.  K VPRHF D:$$ZERO^VPRENC("HF",+DIEN) VHF^PXPXRM(+DIEN,.VPRHF)
  1.  S VPRVST=+$G(VPRHF("VISIT")),VPRVST0=$G(^AUPNVSIT(+VPRVST,0))
  1.  S VPRHF=DIEN,DIEN=+DIEN
  1.  Q
  1.  ;
  1. POV1 ; -- get info for single POV record [ID Action]
  1.  ; Expects/updates DIEN = #9000010.07 ien
  1.  ;       Returns VPRVST = #9000010 ien
  1.  ;              VPRVST0 = Visit zero node
  1.  ;               VPREDP = #230 ien or 0
  1.  ;               VPRPOV array
  1.  K VPRPOV D:$$ZERO^VPRENC("POV",+DIEN) VPOV^PXPXRM(+DIEN,.VPRPOV)
  1.  S VPRVST=+$G(VPRPOV("VISIT")),VPRVST0=$G(^AUPNVSIT(VPRVST,0))
  1.  S VPREDP=+$O(^EDP(230,"V",VPRVST,0)) ;#230 ien if EDP, or 0
  1.  S VPRPOV=DIEN,DIEN=+DIEN
  1.  Q
  1.  ;
  1. POVNARR() ; -- build Original Text for POV
  1.  N NARR,MOD,Y S Y=""
  1.  S NARR=$G(VPRPOV("PROVIDER NARRATIVE")),MOD=$G(VPRPOV("MODIFIER"))
  1.  S:NARR Y=$$GET1^DIQ(9999999.27,NARR_",",.01)
  1.  I $L(MOD),$L(Y) S Y=$$EXTERNAL^DILFD(9000010.07,.06,,MOD)_" "_Y
  1.  Q Y
  1.  ;
  1. CPT1 ; -- get info for single V CPT record [ID Action]
  1.  ; Expects/updates DIEN = #9000010.18 ien
  1.  ;       Returns VPRVST = #9000010 ien
  1.  ;              VPRVST0 = Visit zero node
  1.  ;               VPRCPT array
  1.  K VPRCPT D:$$ZERO^VPRENC("CPT",+DIEN) VCPT^PXPXRM(+DIEN,.VPRCPT)
  1.  S VPRVST=+$G(VPRCPT("VISIT")),VPRVST0=$G(^AUPNVSIT(VPRVST,0))
  1.  S VPRCPT=DIEN,DIEN=+DIEN
  1.  Q
  1.  ;
  1. VCPT(DA) ; -- ok to include V-CPT record in SDA?
  1.  N X0,CODE,PKG,VST S DA=+$G(DA)
  1.  ; skip eval/mgt codes
  1.  S X0=$$ZERO^VPRENC("CPT",DA),CODE=$P(X0,U) I CODE>99200,CODE<99500 Q 0
  1.  ; skip Surgery (duplicates of #130)
  1.  S PKG=$$GET1^DIQ(9000010.18,DA,81202,"I")
  1.  I PKG,$P($G(^DIC(9.4,PKG,0)),U,2)="SR" Q 0
  1.  ; skip V IMMUNIZATIONS codes
  1.  S VST=+$P(X0,U,3)
  1.  I $$DUP(VST,CODE,"IMM") Q 0
  1.  ; else ok
  1.  Q 1
  1.  ;
  1. DUP(VST,CPT,SUB) ; -- find V CPT match in VSUB file (IMM or SK)
  1.  N VFL,GBL,IEN,ITM,SYS,Y
  1.  I '$G(VST)!($G(CPT)="")!($G(SUB)="") Q 0
  1.  S VFL="^AUPNV"_SUB,GBL="^AUTT"_SUB,Y=0
  1.  S IEN=0 F  S IEN=$O(@VFL@("AD",+VST,IEN)) Q:IEN<1  D  Q:Y
  1.  . S ITM=+$G(@VFL@(IEN,0)),SYS=+$O(@GBL@(ITM,3,"B","CPT",0))
  1.  . I SYS,+$O(@GBL@(ITM,3,SYS,1,"B",CPT,0)) S Y=IEN
  1.  Q Y