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

BARCFLD.m

Go to the documentation of this file. 
  1. BARCFLD ; IHS/SD/LSL - Computed Fields Routine ; 10/27/2008
  1.  ;;1.8;IHS ACCOUNTS RECEIVABLE;**10,13,23**;OCT 26, 2005
  1.  ;JUL 2013 P.OTTIS ADDED SUPPORT FOR ICD-10
  1.  Q
  1.  ; ********************************************************************
  1.  ;
  1. DSCHSVC() ;EP
  1.  ; New as of V1.7 patch 1 - needed for financial report sorting
  1.  ; Discharge Service Field on A/R Bill File (field 23 of file 90050.01)
  1.  ; Will actually return a pointer to FACILITY TREATING SPECIALTY file
  1.  ;
  1.  N BAR,BAR3PLOC,BAR3PIEN,BAR3PDUZ,DIC,DA,BAR3PPC,BARPVIS,BARHOSP,BARDSCH
  1.  ;
  1.  ; First find 3P Bill
  1.  S BAR=D0
  1.  N D0
  1.  S BAR3PLOC=$$FIND3PB^BARUTL(DUZ(2),BAR)
  1.  I BAR3PLOC="" Q ""
  1.  S BAR3PIEN=$P(BAR3PLOC,",",2)
  1.  S BAR3PDUZ=$P(BAR3PLOC,",")
  1.  ;
  1.  ; Find primary Visit
  1.  S BAR3PPC=0
  1.  F  S BAR3PPC=$O(^ABMDBILL(BAR3PDUZ,BAR3PIEN,11,BAR3PPC)) Q:'+BAR3PPC  D
  1.  . I $P($G(^ABMDBILL(BAR3PDUZ,BAR3PIEN,11,BAR3PPC,0)),U,2)="P" D  Q
  1.  . . S BARPVIS=$P($G(^ABMDBILL(BAR3PDUZ,BAR3PIEN,11,BAR3PPC,0)),U)
  1.  . . Q
  1.  I $G(BARPVIS)="" Q ""
  1.  ;
  1.  ; Find Discharge Service
  1.  S BARHOSP=$O(^AUPNVINP("AD",BARPVIS,0))
  1.  I '+BARHOSP Q ""
  1.  S BARDSCH=$P($G(^AUPNVINP(BARHOSP,0)),U,5)
  1.  Q BARDSCH
  1.  ; ********************************************************************
  1.  ;
  1. PRIMDIAG() ;EP
  1.  ;RETURNS DX ICD CODE (EXTERNAL)
  1.  ; New as of V1.7 Patch 1 - needed for financial report sorting
  1.  ; Primary Diagnosis Field on A/R Bill File (field 24 of file 90050.01)
  1.  ; Will actually return the .01 value of the ICD DIAGNOSIS file
  1.  ; (ICD9 Diagnosis Code)
  1.  ; (routine released in 1.7 patch 1, field not released til V1.8)
  1.  ;
  1.  N BAR,BAR3PLOC,BAR3PIEN,BAR3PDUZ,DIC,DA,BAR3PPC,BARPVIS,BARHOSP,BARDSCH
  1.  ;
  1.  ; First find 3P Bill
  1.  S BAR=D0
  1.  N D0
  1.  S BAR3PLOC=$$FIND3PB^BARUTL(DUZ(2),BAR)
  1.  I BAR3PLOC="" Q ""
  1.  S BAR3PIEN=$P(BAR3PLOC,",",2)
  1.  S BAR3PDUZ=$P(BAR3PLOC,",")
  1.  ;
  1.  ; Find the primary diagnosis
  1.  S (BAR3PDX,BARPRMDX)=0
  1.  F  S BAR3PDX=$O(^ABMDBILL(BAR3PDUZ,BAR3PIEN,17,BAR3PDX)) Q:'+BAR3PDX  D  Q:+BARPRMDX
  1.  . S BAR3PDXP=$P($G(^ABMDBILL(BAR3PDUZ,BAR3PIEN,17,BAR3PDX,0)),U,2)
  1.  . I BAR3PDXP=1 S BARPRMDX=1 ;I DUZ=838 W "  <-- PRIM"
  1.  I '+BARPRMDX Q ""
  1.  ;
  1.  ;
  1.  I $T(+1^ICDEX)="" S BARPRMDX=$P($$ICDDX^ICDCODE(BAR3PDX,""),U,2)  ;IHS/SD/SDR 5/1/09 H4329 (P.OTT OLD CODE)
  1.  I $T(+1^ICDEX)]"" S BARPRMDX=$P($$ICDDX^ICDEX(BAR3PDX,""),U,2)  ;P.OTT ICD-10 (NEW API)
  1.  I BARPRMDX=-1 Q ""
  1.  Q BARPRMDX
  1.  ;End changes for CSV
  1.  ;--------------------------------
  1. PRIMDXI() ;EP
  1.  ;
  1.  ;returns IEN of primary DX (ptr into ^ICD9)
  1.  ;
  1.  N BAR,BAR3PLOC,BAR3PIEN,BAR3PDUZ,DIC,DA,BAR3PPC,BARPVIS,BARHOSP,BARDSCH,BARDXDA
  1.  ;
  1.  S BAR=D0
  1.  N D0
  1.  S BAR3PLOC=$$FIND3PB^BARUTL(DUZ(2),BAR)
  1.  I BAR3PLOC="" Q ""
  1.  S BAR3PIEN=$P(BAR3PLOC,",",2)
  1.  S BAR3PDUZ=$P(BAR3PLOC,",")
  1.  ;
  1.  ; Find the primary diagnosis ein
  1.  ;
  1.  S (BARDXDA,BARPRMDX)=0
  1.  F  S BARDXDA=$O(^ABMDBILL(BAR3PDUZ,BAR3PIEN,17,BARDXDA)) Q:'+BARDXDA  D  Q:+BARPRMDX
  1.  . S BAR3PDXP=$P($G(^ABMDBILL(BAR3PDUZ,BAR3PIEN,17,BARDXDA,0)),U,2)
  1.  . I BAR3PDXP=1 S BARPRMDX=1 ;I DUZ=838 W "  <-- PRIM"
  1.  I '+BARPRMDX Q ""  ;no primary
  1.  Q BARDXDA
  1.  ;--------------------------------
  1. ICDVER() ;P.OTT
  1.  ;called from A/R Bill File: calculated fld 'ICD CODE INDICATOR"
  1.  ;returns ICD coding string e.g. ICD-9-CM
  1.  ;
  1.  N BARDXA,BARDXS
  1.  S BARDXDA=$$PRIMDXI()
  1.  I BARDXDA="" Q ""
  1.  I $T(+1^ICDEX)="" Q "ICD-9-CM"
  1.  S BARDXS=+$G(^ICD9(BARDXDA,1))
  1.  I 'BARDXS Q ""
  1.  Q $P($G(^ICDS(BARDXS,0)),U,1)
  1.  ;-------------------
  1. ICD10FLG(BARDXDA) ;P.OTT
  1.  ;BARDXDA = IEN TO ^ICD(9
  1.  ;returns 1 if BARDXDA is a valid IDC-10 DX code
  1.  I BARDXDA="" Q ""
  1.  I $T(+1^ICDEX)="" Q 0
  1.  S BARDXS=+$G(^ICD9(BARDXDA,1))
  1.  I 'BARDXS Q ""
  1.  Q BARDXS=30!(BARDXS=31) ;
  1.  ;------------------EOR-------------------
  1. TEST F I=500001:1:500005 W !,I," (10)==>  ",$$ICD10FLG(I),"<=="
  1.  F I=1:1:15 W !,I," (9)==>  ",$$ICD10FLG(I),"<=="
  1.  Q  ;EOR