IBCSC4D ;ALB/ARH - ADD/ENTER DIAGNOSIS ;11/9/93
;;2.0;INTEGRATED BILLING;**55,62,91,106,124,51,210,403,400,461,516,522**;21-MAR-94;Build 11
;;Per VA Directive 6402, this routine should not be modified.
;
EN ;add/edit diagnosis for a bill, IBIFN required
N IBINP,POAEDIT
S POAEDIT=0 ; flag for editing POA indicators, set in DXINPT^IBCSC4E
S IBX=$G(^DGCR(399,+IBIFN,0))
S IBINP=$$INPAT^IBCEF(+IBIFN)
D DELALL^IBCSC4E(+IBIFN)
I IBINP D DXINPT^IBCSC4E(IBIFN)
I 'IBINP D DXOPT(IBIFN)
S IBDIFN=0 D SET(IBIFN,.IBDXA,.IBPOA) D:+IBDXA DISP(.IBPOA)
I IBINP,$D(^IBA(362.3,"AO",IBIFN)),$$FT^IBCEF(IBIFN)=3,POAEDIT D POAASK^IBCSC4E
;
; esg - IB*2*400 - ask for PPS (DRG) for inpatient, UB claims
I IBINP,$$FT^IBCEF(IBIFN)=3 D I $D(Y) G EXIT
. N DIE,DA,DR,ICDVDT
. S ICDVDT=$$BDATE^IBACSV(IBIFN)
. S DIE=399,DA=IBIFN,DR="170T" D ^DIE
. W !
. Q
;
E1 S IBDX=$$ASKDX I +IBDX>0 S IBDIFN=+$G(IBDXA(+IBDX)) S:'IBDIFN IBDIFN=$$ADD(+IBDX,IBIFN) G:+IBDIFN=0 E1 I +IBDIFN>0 D EDIT(+IBDIFN) D SET(IBIFN,.IBDXA,.IBPOA) G E1
S IBX=$G(^DGCR(399,+IBIFN,0)) I $P(IBX,U,5)<3,$P(IBX,U,27)'=2 S DGRVRCAL=1
EXIT K IBDIFN,IBDXA,IBPOA,IBDX,IBX
Q
;
ASKDX() ;
N X,Y,IBDATE,IBDTTX,ICDVDT
;S DIR("A")="Select ICD DIAGNOSIS",DIR(0)="362.3,.01O" D ^DIR K DIR
S IBDATE=$$BDATE^IBACSV(IBIFN),ICDVDT=IBDATE
S IBDTTX=$$DAT1^IBOUTL(IBDATE)
I $G(IBIFN),$$INPAT^IBCEF(IBIFN) D
. N Z S Z=$$EXPAND^IBTRE(399,215,+$G(^DGCR(399,IBIFN,"U2")))
. W !,$S(Z'="":"",1:"NO ")_"Admitting Diagnosis"_$S(Z'="":": "_Z,1:" found"),!
AD S DIR("??")="^D HELP^IBCSC4D"
S DIR("?",1)="Enter a diagnosis for this bill. Duplicates are not allowed."
S DIR("?")="Only diagnosis codes active on "_IBDTTX_", no duplicates for a bill, and bill must not be authorized or cancelled."
S DIR("S")="I $$ICD9VER^IBACSV(+Y)="_$$ICD9SYS^IBACSV(IBDATE) ; inactive allowed but either ICD-9 or ICD-10 *461
S DIR(0)="PO^80:EAMQI"
D ^DIR K DIR
I Y>0,'$D(IBDXA(+Y)),'$$ICD9ACT^IBACSV(+Y,IBDATE) D G AD
. W !!,*7,"The Diagnosis code is inactive for the date of service ("_IBDTTX_").",!
Q Y
;
ADD(DX,IFN,DXPOA) ;
I $$ICD9VER^IBACSV(DX)=1,$E($$ICD9^IBACSV(DX,$$BDATE^IBACSV(IFN)))="E",$$MAXECODE^IBCSC4F(IFN) W !!,*7,"Only 3 External Cause of Injury diagnoses are allowed per claim.",! Q 0
S DIC("DR")=".02////"_IFN I $G(DXPOA)'="" S DIC("DR")=DIC("DR")_";.04///"_DXPOA
S DIC="^IBA(362.3,",DIC(0)="AQL",X=DX K DA,DO D FILE^DICN K DA,DO,DIC,X
Q Y
;
EDIT(IBDXIFN) ;
N NEEDPOA
S DIDEL=362.3,DIE="^IBA(362.3,",DA=IBDXIFN
; only ask for POA if inpatient UB-04 claim
S NEEDPOA=IBINP&($$FT^IBCEF(IBIFN)=3)
S DR=".01Diagnosis"_$S(NEEDPOA:";.04POA Indicator",1:"")_";.03Order"
D ^DIE K DIE,DR,DA,DIC,DIDEL
;
I $D(^IBA(362.3,IBDXIFN,0)),$$FIRSTDX(IBDXIFN) D G EDITQ
. N DIE,DR,DA,Y,X,IB0
. S IB0=^IBA(362.3,IBDXIFN,0)
. S DIE="^DGCR(399,",DA=+$P(IB0,U,2),DR="215////"_+IB0 D ^DIE
;
; MRD;IB*2.0*516 - Added '$D check *before* removing the dangling
; pointers; and added code to 'shift' subsequent pointers, if any.
; If the entry was deleted, remove dangling pointers from #399.0304.
I '$D(^IBA(362.3,IBDXIFN)) D
. N IBPROC,IBPROCD,IBPIECE,IBHIT
. S (IBHIT,IBPROC)=0
. F S IBPROC=$O(^DGCR(399,IBIFN,"CP",IBPROC)) Q:'IBPROC S IBPROCD=$G(^(IBPROC,0)) I IBPROCD]"" D
. . F IBPIECE=11:1:14 I +$P(IBPROCD,"^",IBPIECE)=IBDXIFN S IBHIT=1 D UPD^IBCU72("@",IBPIECE-1)
. . Q
. ;
. ; If a pointer to the deleted DX code was found and removed, then
. ; sound <bell>, display message, and 'shift' any other associated
. ; DX codes to close the gap, if any.
. I IBHIT D
. . W *7,!,"This diagnosis was removed as a procedure diagnosis."
. . ;
. . S IBPROC=0
. . F S IBPROC=$O(^DGCR(399,IBIFN,"CP",IBPROC)) Q:'IBPROC S IBPROCD=$G(^(IBPROC,0)) I IBPROCD]"" D
. . . F IBPIECE=11:1:13 D
. . . . ; If DX field is blank, and next one is not blank, then shift it 'up'.
. . . . I $P(IBPROCD,"^",IBPIECE)="",$P(IBPROCD,"^",IBPIECE+1)'="" D
. . . . . D UPD^IBCU72("@",IBPIECE) ; Delete from one slot...
. . . . . D UPD^IBCU72($P(IBPROCD,"^",IBPIECE+1),IBPIECE-1) ; Add to the blank slot.
. . . . . S IBPROCD=$G(^DGCR(399,IBIFN,"CP",IBPROC,0)) ; Grab updated version of this node.
. . . . . Q
. . . . Q
. . . Q
. . Q
. Q
;
EDITQ Q
;
SET(IFN,DXARR,POARR) ;setup arrays of all dx's for bill, array names should be passed by reference
;returns: DXARR(DX)=DX IFN, POARR(ORDER)=DX ^ PRINT ORDER ^ POA, (DXARR,POARR)=IFN ^ dx count
;if a dx does not have a print order then PRINT ORDER=(999+count of dx) so will be in order of entry if no print order
N CNT,IBX,IBY,IBZ,DIFN,IBC,ARR K DXARR,POARR S IBC="AIFN"_$G(IFN)
S (CNT,IBX)=0 F S IBX=$O(^IBA(362.3,IBC,IBX)) Q:'IBX D
. S DIFN=$O(^IBA(362.3,IBC,IBX,0)),IBY=$G(^IBA(362.3,DIFN,0)) Q:'IBY
. S CNT=CNT+1,IBZ=+$P(IBY,U,3) I 'IBZ S IBZ=999+CNT
. S DXARR(+IBY)=DIFN,ARR(IBZ)=+IBY_U_$P(IBY,U,3,4)
S (IBX,IBY)=0 F S IBY=$O(ARR(IBY)) Q:'IBY S IBX=IBX+1,POARR(IBX)=ARR(IBY)
S (DXARR,POARR)=$G(IFN)_"^"_CNT
Q
;
DISP(POARR) ;screen display of existing dx's for a bill,
;input should be print order array returned by SET^IBCSC4D: POARR(PRINT ORDER)=DX, passed by reference
N IBX,IBY,IBZ,IBDATE,POA
S IBDATE=$$BDATE^IBACSV(+$G(IBIFN)) ; The bill date of service
W !!,?5,"----------------- Existing Diagnoses for Bill -----------------",!
S IBX=0 F S IBX=$O(POARR(IBX)) Q:'IBX S IBZ=POARR(IBX),IBY=$$ICD9^IBACSV(+IBZ,IBDATE) D
.S POA="" I $$INPAT^IBCEF(IBIFN),$$FT^IBCEF(IBIFN)=3 S POA=$P(IBZ,U,3) S:POA=1 POA="" S:POA'="" POA="("_POA_")"
. W !,$P(IBY,U),?9,POA,?13,$P(IBY,U,3),?75,$S($P(IBZ,U,2)<1000:"("_$P(IBZ,U,2)_")",1:"")
W !
Q
;
DISP1(IFN) ;
I +$G(IFN) N POARR D SET(IFN,"",.POARR),DISP(.POARR)
Q
HELP ;called for help from dx enter to display existing dx's
Q:'$G(IBIFN) N IBX
D SET(IBIFN,.IBDXA,"") S IBX=$G(^DGCR(399,+IBIFN,0)) I IBX="" Q
I $P(IBX,U,5)>2 S DFN=$P(IBX,U,2),IBX=$G(^DGCR(399,+IBIFN,"U")) D OPTDX(DFN,$P(IBX,U,1),$P(IBX,U,2),.IBOEDX,.IBDXA),DISPOE(.IBOEDX,.IBDXA)
D SET(IBIFN,.IBDXA,.IBPOA) D:+IBDXA DISP(.IBPOA)
Q
;
ADD1(IFN) ;does not work, but it should replace ask add, and edit
;S DIC="^IBA(362.3,",DIC(0)="EMAQ",D="AIFN"_$G(IFN) D IX^DIC K DA,DO,DIC,D
Q
;
; ******************************************************************************************
;
DXOPT(IBIFN) ; display and ask user to select PCE diagnosis
N IBDXA,IBOEDX,IBLIST,DFN,IBX
D SET(IBIFN,.IBDXA,"")
S DFN=$P($G(^DGCR(399,+IBIFN,0)),U,2),IBX=$G(^DGCR(399,+IBIFN,"U"))
D OPTDX(DFN,$P(IBX,U,1),$P(IBX,U,2),.IBOEDX,.IBDXA),DISPOE(.IBOEDX,.IBDXA)
I +$P($G(IBOEDX),U,2) D NEWDX(+IBOEDX) I $D(IBLIST) D ADDNEW(IBIFN,IBLIST,.IBOEDX)
Q
;
OPTDX(DFN,DT1,DT2,ARRAY,IBDXE) ; get diagnosis from PCE for encounters within date range
; ARRAY(X)= DX ^ ORDER ^ OUTPATIENT ENCOUNTER (409.68) ^ DATE/TIME ^ TRUE IF NON-BILL ^ NON-BILL MESS ^ CLINIC
N IBDT,IBOE,IBDX,IBDXN,IBDXA,IBDXB,IBCNT,IBCNT1,ARR,IBI,IBJ,IBK,IBVAL,IBCBK
K ARRAY
S (IBCNT,IBCNT1)=0,DT1=$G(DT1)-.0001,DT2=$S(+$G(DT2):DT2,1:9999999)+.7999
;
S IBVAL("DFN")=DFN,IBVAL("BDT")=DT1,IBVAL("EDT")=DT2
S IBCBK="D OEDX^IBCU81(Y,.IBDXA,.IBDXB)"
D SCAN^IBSDU("PATIENT/DATE",.IBVAL,"",IBCBK,1) K ^TMP("DIERR",$J)
;
S (IBCNT,IBCNT1,IBI)=0 F S IBI=$O(IBDXA(IBI)) Q:'IBI D
. S IBJ=0 F S IBJ=$O(IBDXA(IBI,IBJ)) Q:'IBJ D
.. S IBK=0 F S IBK=$O(IBDXA(IBI,IBJ,IBK)) Q:'IBK D
... S IBDXN=0 F S IBDXN=$O(IBDXA(IBI,IBJ,IBK,IBDXN)) Q:'IBDXN D
.... S IBDX=IBDXA(IBI,IBJ,IBK,IBDXN) I $D(ARR(+IBDX))!(+$P(IBDX,U,5)&(+$G(IBDXB(+IBDX)))) Q
.... S IBCNT=IBCNT+1 I '$D(IBDXE(+IBDX)) S IBCNT1=IBCNT1+1
.... S ARRAY(IBCNT)=IBDX S ARR(+IBDX)=""
S ARRAY=IBCNT_"^"_IBCNT1 K IBDXA,IBDXB,ARR
Q
;
NEWDX(IBX) ; user select PCE diagnosis to add to bill
Q:'$G(IBX) N X,Y,DIR,DIRUT K IBLIST W !
NEWDX1 S DIR("?",1)="Enter the number preceding the Diagnosis you want added to the bill.",DIR("?",2)="Multiple entries may be added separated by commas or ranges separated by a dash."
S DIR("?")="The diagnosis will be added to the bill with a print order corresponding to its position in this list."
S DIR("A")="SELECT NEW DIAGNOSES TO ADD THE BILL"
S DIR(0)="LO^1:"_+IBX D ^DIR K DIR G:'Y!$D(DIRUT) NEWDXE
S IBLIST=Y
;
S DIR("A")="YOU HAVE SELECTED "_IBLIST_" TO BE ADDED TO THE BILL IS THIS CORRECT",DIR("B")="YES"
S DIR(0)="YO" D ^DIR K DIR I $D(DIRUT) K IBLIST G NEWDXE
I 'Y G NEWDX1
NEWDXE Q
;
ADDNEW(IBIFN,LIST,IBOEA) ; add selected PCE diagnosis to bill
Q:'LIST N IBI,IBX,IBDX,IBDT,IBQ,IBY,IBPIFN,IBZ
F IBI=1:1 S IBX=$P(LIST,",",IBI) Q:'IBX I $D(IBOEA(IBX)) D
. S IBDX=+IBOEA(IBX) I $D(^IBA(362.3,"AIFN"_IBIFN,IBDX)) Q
. I $$ADD(IBDX,IBIFN) W "."
Q
;
DISPOE(OEARR,EXARR) ; display outpatient PCE diagnosis
N IBCNT,IBDX,IBX,IBY,IBDATE
W @IOF,!,"============================= DIAGNOSIS SCREEN ==============================",!
S IBDATE=$$BDATE^IBACSV(+$G(IBIFN)) ; The bills date of service
S IBCNT=0 F S IBCNT=$O(OEARR(IBCNT)) Q:'IBCNT D
. S IBY=OEARR(IBCNT),IBDX=$$ICD9^IBACSV(+IBY,IBDATE)
. S IBX="" I $D(EXARR(+OEARR(IBCNT))) S IBX="*"
. W !,$J(IBCNT,2),")",?4,IBX,?5,$P(IBDX,U),?14,$E($P(IBDX,U,3),1,19)
. I +$P(IBY,U,7) W ?35,$E($P($G(^SC(+$P(IBY,U,7),0)),U,1),1,15)
. I $P(IBY,U,2)'="" W ?52,$E($$EXPAND^IBTRE(9000010.07,.12,$P(IBY,U,2)),1,3)
. I $P(IBY,U,4)'="" W ?57,$$FMTE^XLFDT($E($P(IBY,U,4),1,12),2)
. I $P(IBY,U,6)'="" W ?72,$E($P(IBY,U,6),1,7)
Q
;
DISPID ; Display the Associated Dx and Rx # for a procedure in the identifier.
; Input: Naked reference to the 0th node of an entry in the
; Procedures (#304) sub-file of the Bill/Claims (#399) file.
N I,X,IBY,Z
S X=^(0),IBY=Y
S I=$$PRCNM^IBCSCH1($P(X,U,1),$P(X,U,2)) W " ",$E($P(I,U,2)_$J("",27),1,27)
S Z=$O(^DGCR(399,DA(1),"RC","ACP",+IBY,0))
I Z S Z=$P($G(^DGCR(399,DA(1),"RC",Z,0)),U,11) W $E(" Rx: "_$S(Z:$P($G(^IBA(362.4,+Z,0)),U),1:"Missing")_$J("",14),1,14)
I +$P(X,U,11) S I=+$G(^IBA(362.3,+$P(X,U,11),0)) W " Dx 1: ",$P($$ICD9^IBACSV(+I,$$BDATE^IBACSV(DA(1))),U)
Q
FIRSTDX(DA) ; Called by trigger cross reference #2 on file 362.3,.03
; DA is the ien of the entry in file 362.3
; Check if the corresponding bill is for an inpatient episode, the
; admitting dx for the corresponding bill is null and the dx being
; entered is the first for the bill. If this is all true, admitting
; dx should be set to the dx.
;
N OK,Z
S Z=$G(^IBA(362.3,DA,0)),OK=0
I $$INPAT^IBCEF(+$P(Z,U,2)),$P($G(^DGCR(399,+$P(Z,U,2),"U2")),U)="",'$O(^IBA(362.3,"AO",+$P(Z,U,2),+$P(Z,U,3)),-1) S OK=1
Q OK
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCSC4D 10644 printed Oct 16, 2024@18:20:56 Page 2
IBCSC4D ;ALB/ARH - ADD/ENTER DIAGNOSIS ;11/9/93
+1 ;;2.0;INTEGRATED BILLING;**55,62,91,106,124,51,210,403,400,461,516,522**;21-MAR-94;Build 11
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ;add/edit diagnosis for a bill, IBIFN required
+1 NEW IBINP,POAEDIT
+2 ; flag for editing POA indicators, set in DXINPT^IBCSC4E
SET POAEDIT=0
+3 SET IBX=$GET(^DGCR(399,+IBIFN,0))
+4 SET IBINP=$$INPAT^IBCEF(+IBIFN)
+5 DO DELALL^IBCSC4E(+IBIFN)
+6 IF IBINP
DO DXINPT^IBCSC4E(IBIFN)
+7 IF 'IBINP
DO DXOPT(IBIFN)
+8 SET IBDIFN=0
DO SET(IBIFN,.IBDXA,.IBPOA)
if +IBDXA
DO DISP(.IBPOA)
+9 IF IBINP
IF $DATA(^IBA(362.3,"AO",IBIFN))
IF $$FT^IBCEF(IBIFN)=3
IF POAEDIT
DO POAASK^IBCSC4E
+10 ;
+11 ; esg - IB*2*400 - ask for PPS (DRG) for inpatient, UB claims
+12 IF IBINP
IF $$FT^IBCEF(IBIFN)=3
Begin DoDot:1
+13 NEW DIE,DA,DR,ICDVDT
+14 SET ICDVDT=$$BDATE^IBACSV(IBIFN)
+15 SET DIE=399
SET DA=IBIFN
SET DR="170T"
DO ^DIE
+16 WRITE !
+17 QUIT
End DoDot:1
IF $DATA(Y)
GOTO EXIT
+18 ;
E1 SET IBDX=$$ASKDX
IF +IBDX>0
SET IBDIFN=+$GET(IBDXA(+IBDX))
if 'IBDIFN
SET IBDIFN=$$ADD(+IBDX,IBIFN)
if +IBDIFN=0
GOTO E1
IF +IBDIFN>0
DO EDIT(+IBDIFN)
DO SET(IBIFN,.IBDXA,.IBPOA)
GOTO E1
+1 SET IBX=$GET(^DGCR(399,+IBIFN,0))
IF $PIECE(IBX,U,5)<3
IF $PIECE(IBX,U,27)'=2
SET DGRVRCAL=1
EXIT KILL IBDIFN,IBDXA,IBPOA,IBDX,IBX
+1 QUIT
+2 ;
ASKDX() ;
+1 NEW X,Y,IBDATE,IBDTTX,ICDVDT
+2 ;S DIR("A")="Select ICD DIAGNOSIS",DIR(0)="362.3,.01O" D ^DIR K DIR
+3 SET IBDATE=$$BDATE^IBACSV(IBIFN)
SET ICDVDT=IBDATE
+4 SET IBDTTX=$$DAT1^IBOUTL(IBDATE)
+5 IF $GET(IBIFN)
IF $$INPAT^IBCEF(IBIFN)
Begin DoDot:1
+6 NEW Z
SET Z=$$EXPAND^IBTRE(399,215,+$GET(^DGCR(399,IBIFN,"U2")))
+7 WRITE !,$SELECT(Z'="":"",1:"NO ")_"Admitting Diagnosis"_$SELECT(Z'="":": "_Z,1:" found"),!
End DoDot:1
AD SET DIR("??")="^D HELP^IBCSC4D"
+1 SET DIR("?",1)="Enter a diagnosis for this bill. Duplicates are not allowed."
+2 SET DIR("?")="Only diagnosis codes active on "_IBDTTX_", no duplicates for a bill, and bill must not be authorized or cancelled."
+3 ; inactive allowed but either ICD-9 or ICD-10 *461
SET DIR("S")="I $$ICD9VER^IBACSV(+Y)="_$$ICD9SYS^IBACSV(IBDATE)
+4 SET DIR(0)="PO^80:EAMQI"
+5 DO ^DIR
KILL DIR
+6 IF Y>0
IF '$DATA(IBDXA(+Y))
IF '$$ICD9ACT^IBACSV(+Y,IBDATE)
Begin DoDot:1
+7 WRITE !!,*7,"The Diagnosis code is inactive for the date of service ("_IBDTTX_").",!
End DoDot:1
GOTO AD
+8 QUIT Y
+9 ;
ADD(DX,IFN,DXPOA) ;
+1 IF $$ICD9VER^IBACSV(DX)=1
IF $EXTRACT($$ICD9^IBACSV(DX,$$BDATE^IBACSV(IFN)))="E"
IF $$MAXECODE^IBCSC4F(IFN)
WRITE !!,*7,"Only 3 External Cause of Injury diagnoses are allowed per claim.",!
QUIT 0
+2 SET DIC("DR")=".02////"_IFN
IF $GET(DXPOA)'=""
SET DIC("DR")=DIC("DR")_";.04///"_DXPOA
+3 SET DIC="^IBA(362.3,"
SET DIC(0)="AQL"
SET X=DX
KILL DA,DO
DO FILE^DICN
KILL DA,DO,DIC,X
+4 QUIT Y
+5 ;
EDIT(IBDXIFN) ;
+1 NEW NEEDPOA
+2 SET DIDEL=362.3
SET DIE="^IBA(362.3,"
SET DA=IBDXIFN
+3 ; only ask for POA if inpatient UB-04 claim
+4 SET NEEDPOA=IBINP&($$FT^IBCEF(IBIFN)=3)
+5 SET DR=".01Diagnosis"_$SELECT(NEEDPOA:";.04POA Indicator",1:"")_";.03Order"
+6 DO ^DIE
KILL DIE,DR,DA,DIC,DIDEL
+7 ;
+8 IF $DATA(^IBA(362.3,IBDXIFN,0))
IF $$FIRSTDX(IBDXIFN)
Begin DoDot:1
+9 NEW DIE,DR,DA,Y,X,IB0
+10 SET IB0=^IBA(362.3,IBDXIFN,0)
+11 SET DIE="^DGCR(399,"
SET DA=+$PIECE(IB0,U,2)
SET DR="215////"_+IB0
DO ^DIE
End DoDot:1
GOTO EDITQ
+12 ;
+13 ; MRD;IB*2.0*516 - Added '$D check *before* removing the dangling
+14 ; pointers; and added code to 'shift' subsequent pointers, if any.
+15 ; If the entry was deleted, remove dangling pointers from #399.0304.
+16 IF '$DATA(^IBA(362.3,IBDXIFN))
Begin DoDot:1
+17 NEW IBPROC,IBPROCD,IBPIECE,IBHIT
+18 SET (IBHIT,IBPROC)=0
+19 FOR
SET IBPROC=$ORDER(^DGCR(399,IBIFN,"CP",IBPROC))
if 'IBPROC
QUIT
SET IBPROCD=$GET(^(IBPROC,0))
IF IBPROCD]""
Begin DoDot:2
+20 FOR IBPIECE=11:1:14
IF +$PIECE(IBPROCD,"^",IBPIECE)=IBDXIFN
SET IBHIT=1
DO UPD^IBCU72("@",IBPIECE-1)
+21 QUIT
End DoDot:2
+22 ;
+23 ; If a pointer to the deleted DX code was found and removed, then
+24 ; sound <bell>, display message, and 'shift' any other associated
+25 ; DX codes to close the gap, if any.
+26 IF IBHIT
Begin DoDot:2
+27 WRITE *7,!,"This diagnosis was removed as a procedure diagnosis."
+28 ;
+29 SET IBPROC=0
+30 FOR
SET IBPROC=$ORDER(^DGCR(399,IBIFN,"CP",IBPROC))
if 'IBPROC
QUIT
SET IBPROCD=$GET(^(IBPROC,0))
IF IBPROCD]""
Begin DoDot:3
+31 FOR IBPIECE=11:1:13
Begin DoDot:4
+32 ; If DX field is blank, and next one is not blank, then shift it 'up'.
+33 IF $PIECE(IBPROCD,"^",IBPIECE)=""
IF $PIECE(IBPROCD,"^",IBPIECE+1)'=""
Begin DoDot:5
+34 ; Delete from one slot...
DO UPD^IBCU72("@",IBPIECE)
+35 ; Add to the blank slot.
DO UPD^IBCU72($PIECE(IBPROCD,"^",IBPIECE+1),IBPIECE-1)
+36 ; Grab updated version of this node.
SET IBPROCD=$GET(^DGCR(399,IBIFN,"CP",IBPROC,0))
+37 QUIT
End DoDot:5
+38 QUIT
End DoDot:4
+39 QUIT
End DoDot:3
+40 QUIT
End DoDot:2
+41 QUIT
End DoDot:1
+42 ;
EDITQ QUIT
+1 ;
SET(IFN,DXARR,POARR) ;setup arrays of all dx's for bill, array names should be passed by reference
+1 ;returns: DXARR(DX)=DX IFN, POARR(ORDER)=DX ^ PRINT ORDER ^ POA, (DXARR,POARR)=IFN ^ dx count
+2 ;if a dx does not have a print order then PRINT ORDER=(999+count of dx) so will be in order of entry if no print order
+3 NEW CNT,IBX,IBY,IBZ,DIFN,IBC,ARR
KILL DXARR,POARR
SET IBC="AIFN"_$GET(IFN)
+4 SET (CNT,IBX)=0
FOR
SET IBX=$ORDER(^IBA(362.3,IBC,IBX))
if 'IBX
QUIT
Begin DoDot:1
+5 SET DIFN=$ORDER(^IBA(362.3,IBC,IBX,0))
SET IBY=$GET(^IBA(362.3,DIFN,0))
if 'IBY
QUIT
+6 SET CNT=CNT+1
SET IBZ=+$PIECE(IBY,U,3)
IF 'IBZ
SET IBZ=999+CNT
+7 SET DXARR(+IBY)=DIFN
SET ARR(IBZ)=+IBY_U_$PIECE(IBY,U,3,4)
End DoDot:1
+8 SET (IBX,IBY)=0
FOR
SET IBY=$ORDER(ARR(IBY))
if 'IBY
QUIT
SET IBX=IBX+1
SET POARR(IBX)=ARR(IBY)
+9 SET (DXARR,POARR)=$GET(IFN)_"^"_CNT
+10 QUIT
+11 ;
DISP(POARR) ;screen display of existing dx's for a bill,
+1 ;input should be print order array returned by SET^IBCSC4D: POARR(PRINT ORDER)=DX, passed by reference
+2 NEW IBX,IBY,IBZ,IBDATE,POA
+3 ; The bill date of service
SET IBDATE=$$BDATE^IBACSV(+$GET(IBIFN))
+4 WRITE !!,?5,"----------------- Existing Diagnoses for Bill -----------------",!
+5 SET IBX=0
FOR
SET IBX=$ORDER(POARR(IBX))
if 'IBX
QUIT
SET IBZ=POARR(IBX)
SET IBY=$$ICD9^IBACSV(+IBZ,IBDATE)
Begin DoDot:1
+6 SET POA=""
IF $$INPAT^IBCEF(IBIFN)
IF $$FT^IBCEF(IBIFN)=3
SET POA=$PIECE(IBZ,U,3)
if POA=1
SET POA=""
if POA'=""
SET POA="("_POA_")"
+7 WRITE !,$PIECE(IBY,U),?9,POA,?13,$PIECE(IBY,U,3),?75,$SELECT($PIECE(IBZ,U,2)<1000:"("_$PIECE(IBZ,U,2)_")",1:"")
End DoDot:1
+8 WRITE !
+9 QUIT
+10 ;
DISP1(IFN) ;
+1 IF +$GET(IFN)
NEW POARR
DO SET(IFN,"",.POARR)
DO DISP(.POARR)
+2 QUIT
HELP ;called for help from dx enter to display existing dx's
+1 if '$GET(IBIFN)
QUIT
NEW IBX
+2 DO SET(IBIFN,.IBDXA,"")
SET IBX=$GET(^DGCR(399,+IBIFN,0))
IF IBX=""
QUIT
+3 IF $PIECE(IBX,U,5)>2
SET DFN=$PIECE(IBX,U,2)
SET IBX=$GET(^DGCR(399,+IBIFN,"U"))
DO OPTDX(DFN,$PIECE(IBX,U,1),$PIECE(IBX,U,2),.IBOEDX,.IBDXA)
DO DISPOE(.IBOEDX,.IBDXA)
+4 DO SET(IBIFN,.IBDXA,.IBPOA)
if +IBDXA
DO DISP(.IBPOA)
+5 QUIT
+6 ;
ADD1(IFN) ;does not work, but it should replace ask add, and edit
+1 ;S DIC="^IBA(362.3,",DIC(0)="EMAQ",D="AIFN"_$G(IFN) D IX^DIC K DA,DO,DIC,D
+2 QUIT
+3 ;
+4 ; ******************************************************************************************
+5 ;
DXOPT(IBIFN) ; display and ask user to select PCE diagnosis
+1 NEW IBDXA,IBOEDX,IBLIST,DFN,IBX
+2 DO SET(IBIFN,.IBDXA,"")
+3 SET DFN=$PIECE($GET(^DGCR(399,+IBIFN,0)),U,2)
SET IBX=$GET(^DGCR(399,+IBIFN,"U"))
+4 DO OPTDX(DFN,$PIECE(IBX,U,1),$PIECE(IBX,U,2),.IBOEDX,.IBDXA)
DO DISPOE(.IBOEDX,.IBDXA)
+5 IF +$PIECE($GET(IBOEDX),U,2)
DO NEWDX(+IBOEDX)
IF $DATA(IBLIST)
DO ADDNEW(IBIFN,IBLIST,.IBOEDX)
+6 QUIT
+7 ;
OPTDX(DFN,DT1,DT2,ARRAY,IBDXE) ; get diagnosis from PCE for encounters within date range
+1 ; ARRAY(X)= DX ^ ORDER ^ OUTPATIENT ENCOUNTER (409.68) ^ DATE/TIME ^ TRUE IF NON-BILL ^ NON-BILL MESS ^ CLINIC
+2 NEW IBDT,IBOE,IBDX,IBDXN,IBDXA,IBDXB,IBCNT,IBCNT1,ARR,IBI,IBJ,IBK,IBVAL,IBCBK
+3 KILL ARRAY
+4 SET (IBCNT,IBCNT1)=0
SET DT1=$GET(DT1)-.0001
SET DT2=$SELECT(+$GET(DT2):DT2,1:9999999)+.7999
+5 ;
+6 SET IBVAL("DFN")=DFN
SET IBVAL("BDT")=DT1
SET IBVAL("EDT")=DT2
+7 SET IBCBK="D OEDX^IBCU81(Y,.IBDXA,.IBDXB)"
+8 DO SCAN^IBSDU("PATIENT/DATE",.IBVAL,"",IBCBK,1)
KILL ^TMP("DIERR",$JOB)
+9 ;
+10 SET (IBCNT,IBCNT1,IBI)=0
FOR
SET IBI=$ORDER(IBDXA(IBI))
if 'IBI
QUIT
Begin DoDot:1
+11 SET IBJ=0
FOR
SET IBJ=$ORDER(IBDXA(IBI,IBJ))
if 'IBJ
QUIT
Begin DoDot:2
+12 SET IBK=0
FOR
SET IBK=$ORDER(IBDXA(IBI,IBJ,IBK))
if 'IBK
QUIT
Begin DoDot:3
+13 SET IBDXN=0
FOR
SET IBDXN=$ORDER(IBDXA(IBI,IBJ,IBK,IBDXN))
if 'IBDXN
QUIT
Begin DoDot:4
+14 SET IBDX=IBDXA(IBI,IBJ,IBK,IBDXN)
IF $DATA(ARR(+IBDX))!(+$PIECE(IBDX,U,5)&(+$GET(IBDXB(+IBDX))))
QUIT
+15 SET IBCNT=IBCNT+1
IF '$DATA(IBDXE(+IBDX))
SET IBCNT1=IBCNT1+1
+16 SET ARRAY(IBCNT)=IBDX
SET ARR(+IBDX)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+17 SET ARRAY=IBCNT_"^"_IBCNT1
KILL IBDXA,IBDXB,ARR
+18 QUIT
+19 ;
NEWDX(IBX) ; user select PCE diagnosis to add to bill
+1 if '$GET(IBX)
QUIT
NEW X,Y,DIR,DIRUT
KILL IBLIST
WRITE !
NEWDX1 SET DIR("?",1)="Enter the number preceding the Diagnosis you want added to the bill."
SET DIR("?",2)="Multiple entries may be added separated by commas or ranges separated by a dash."
+1 SET DIR("?")="The diagnosis will be added to the bill with a print order corresponding to its position in this list."
+2 SET DIR("A")="SELECT NEW DIAGNOSES TO ADD THE BILL"
+3 SET DIR(0)="LO^1:"_+IBX
DO ^DIR
KILL DIR
if 'Y!$DATA(DIRUT)
GOTO NEWDXE
+4 SET IBLIST=Y
+5 ;
+6 SET DIR("A")="YOU HAVE SELECTED "_IBLIST_" TO BE ADDED TO THE BILL IS THIS CORRECT"
SET DIR("B")="YES"
+7 SET DIR(0)="YO"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
KILL IBLIST
GOTO NEWDXE
+8 IF 'Y
GOTO NEWDX1
NEWDXE QUIT
+1 ;
ADDNEW(IBIFN,LIST,IBOEA) ; add selected PCE diagnosis to bill
+1 if 'LIST
QUIT
NEW IBI,IBX,IBDX,IBDT,IBQ,IBY,IBPIFN,IBZ
+2 FOR IBI=1:1
SET IBX=$PIECE(LIST,",",IBI)
if 'IBX
QUIT
IF $DATA(IBOEA(IBX))
Begin DoDot:1
+3 SET IBDX=+IBOEA(IBX)
IF $DATA(^IBA(362.3,"AIFN"_IBIFN,IBDX))
QUIT
+4 IF $$ADD(IBDX,IBIFN)
WRITE "."
End DoDot:1
+5 QUIT
+6 ;
DISPOE(OEARR,EXARR) ; display outpatient PCE diagnosis
+1 NEW IBCNT,IBDX,IBX,IBY,IBDATE
+2 WRITE @IOF,!,"============================= DIAGNOSIS SCREEN ==============================",!
+3 ; The bills date of service
SET IBDATE=$$BDATE^IBACSV(+$GET(IBIFN))
+4 SET IBCNT=0
FOR
SET IBCNT=$ORDER(OEARR(IBCNT))
if 'IBCNT
QUIT
Begin DoDot:1
+5 SET IBY=OEARR(IBCNT)
SET IBDX=$$ICD9^IBACSV(+IBY,IBDATE)
+6 SET IBX=""
IF $DATA(EXARR(+OEARR(IBCNT)))
SET IBX="*"
+7 WRITE !,$JUSTIFY(IBCNT,2),")",?4,IBX,?5,$PIECE(IBDX,U),?14,$EXTRACT($PIECE(IBDX,U,3),1,19)
+8 IF +$PIECE(IBY,U,7)
WRITE ?35,$EXTRACT($PIECE($GET(^SC(+$PIECE(IBY,U,7),0)),U,1),1,15)
+9 IF $PIECE(IBY,U,2)'=""
WRITE ?52,$EXTRACT($$EXPAND^IBTRE(9000010.07,.12,$PIECE(IBY,U,2)),1,3)
+10 IF $PIECE(IBY,U,4)'=""
WRITE ?57,$$FMTE^XLFDT($EXTRACT($PIECE(IBY,U,4),1,12),2)
+11 IF $PIECE(IBY,U,6)'=""
WRITE ?72,$EXTRACT($PIECE(IBY,U,6),1,7)
End DoDot:1
+12 QUIT
+13 ;
DISPID ; Display the Associated Dx and Rx # for a procedure in the identifier.
+1 ; Input: Naked reference to the 0th node of an entry in the
+2 ; Procedures (#304) sub-file of the Bill/Claims (#399) file.
+3 NEW I,X,IBY,Z
+4 SET X=^(0)
SET IBY=Y
+5 SET I=$$PRCNM^IBCSCH1($PIECE(X,U,1),$PIECE(X,U,2))
WRITE " ",$EXTRACT($PIECE(I,U,2)_$JUSTIFY("",27),1,27)
+6 SET Z=$ORDER(^DGCR(399,DA(1),"RC","ACP",+IBY,0))
+7 IF Z
SET Z=$PIECE($GET(^DGCR(399,DA(1),"RC",Z,0)),U,11)
WRITE $EXTRACT(" Rx: "_$SELECT(Z:$PIECE($GET(^IBA(362.4,+Z,0)),U),1:"Missing")_$JUSTIFY("",14),1,14)
+8 IF +$PIECE(X,U,11)
SET I=+$GET(^IBA(362.3,+$PIECE(X,U,11),0))
WRITE " Dx 1: ",$PIECE($$ICD9^IBACSV(+I,$$BDATE^IBACSV(DA(1))),U)
+9 QUIT
FIRSTDX(DA) ; Called by trigger cross reference #2 on file 362.3,.03
+1 ; DA is the ien of the entry in file 362.3
+2 ; Check if the corresponding bill is for an inpatient episode, the
+3 ; admitting dx for the corresponding bill is null and the dx being
+4 ; entered is the first for the bill. If this is all true, admitting
+5 ; dx should be set to the dx.
+6 ;
+7 NEW OK,Z
+8 SET Z=$GET(^IBA(362.3,DA,0))
SET OK=0
+9 IF $$INPAT^IBCEF(+$PIECE(Z,U,2))
IF $PIECE($GET(^DGCR(399,+$PIECE(Z,U,2),"U2")),U)=""
IF '$ORDER(^IBA(362.3,"AO",+$PIECE(Z,U,2),+$PIECE(Z,U,3)),-1)
SET OK=1
+10 QUIT OK
+11 ;
