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