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

IBCSC4D.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. EN ;add/edit diagnosis for a bill, IBIFN required
  1. N IBINP,POAEDIT
  1. S POAEDIT=0 ; flag for editing POA indicators, set in DXINPT^IBCSC4E
  1. S IBX=$G(^DGCR(399,+IBIFN,0))
  1. S IBINP=$$INPAT^IBCEF(+IBIFN)
  1. D DELALL^IBCSC4E(+IBIFN)
  1. I IBINP D DXINPT^IBCSC4E(IBIFN)
  1. I 'IBINP D DXOPT(IBIFN)
  1. S IBDIFN=0 D SET(IBIFN,.IBDXA,.IBPOA) D:+IBDXA DISP(.IBPOA)
  1. I IBINP,$D(^IBA(362.3,"AO",IBIFN)),$$FT^IBCEF(IBIFN)=3,POAEDIT D POAASK^IBCSC4E
  1. ;
  1. ; esg - IB*2*400 - ask for PPS (DRG) for inpatient, UB claims
  1. I IBINP,$$FT^IBCEF(IBIFN)=3 D I $D(Y) G EXIT
  1. . N DIE,DA,DR,ICDVDT
  1. . S ICDVDT=$$BDATE^IBACSV(IBIFN)
  1. . S DIE=399,DA=IBIFN,DR="170T" D ^DIE
  1. . W !
  1. . Q
  1. ;
  1. 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
  1. S IBX=$G(^DGCR(399,+IBIFN,0)) I $P(IBX,U,5)<3,$P(IBX,U,27)'=2 S DGRVRCAL=1
  1. EXIT K IBDIFN,IBDXA,IBPOA,IBDX,IBX
  1. Q
  1. ;
  1. ASKDX() ;
  1. N X,Y,IBDATE,IBDTTX,ICDVDT
  1. ;S DIR("A")="Select ICD DIAGNOSIS",DIR(0)="362.3,.01O" D ^DIR K DIR
  1. S IBDATE=$$BDATE^IBACSV(IBIFN),ICDVDT=IBDATE
  1. S IBDTTX=$$DAT1^IBOUTL(IBDATE)
  1. I $G(IBIFN),$$INPAT^IBCEF(IBIFN) D
  1. . N Z S Z=$$EXPAND^IBTRE(399,215,+$G(^DGCR(399,IBIFN,"U2")))
  1. . W !,$S(Z'="":"",1:"NO ")_"Admitting Diagnosis"_$S(Z'="":": "_Z,1:" found"),!
  1. S DIR("?",1)="Enter a diagnosis for this bill. Duplicates are not allowed."
  1. S DIR("?")="Only diagnosis codes active on "_IBDTTX_", no duplicates for a bill, and bill must not be authorized or cancelled."
  1. S DIR("S")="I $$ICD9VER^IBACSV(+Y)="_$$ICD9SYS^IBACSV(IBDATE) ; inactive allowed but either ICD-9 or ICD-10 *461
  1. S DIR(0)="PO^80:EAMQI"
  1. D ^DIR K DIR
  1. I Y>0,'$D(IBDXA(+Y)),'$$ICD9ACT^IBACSV(+Y,IBDATE) D G AD
  1. . W !!,*7,"The Diagnosis code is inactive for the date of service ("_IBDTTX_").",!
  1. Q Y
  1. ;
  1. ADD(DX,IFN,DXPOA) ;
  1. 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
  1. S DIC("DR")=".02////"_IFN I $G(DXPOA)'="" S DIC("DR")=DIC("DR")_";.04///"_DXPOA
  1. S DIC="^IBA(362.3,",DIC(0)="AQL",X=DX K DA,DO D FILE^DICN K DA,DO,DIC,X
  1. Q Y
  1. ;
  1. EDIT(IBDXIFN) ;
  1. N NEEDPOA
  1. S DIDEL=362.3,DIE="^IBA(362.3,",DA=IBDXIFN
  1. ; only ask for POA if inpatient UB-04 claim
  1. S NEEDPOA=IBINP&($$FT^IBCEF(IBIFN)=3)
  1. S DR=".01Diagnosis"_$S(NEEDPOA:";.04POA Indicator",1:"")_";.03Order"
  1. D ^DIE K DIE,DR,DA,DIC,DIDEL
  1. ;
  1. I $D(^IBA(362.3,IBDXIFN,0)),$$FIRSTDX(IBDXIFN) D G EDITQ
  1. . N DIE,DR,DA,Y,X,IB0
  1. . S IB0=^IBA(362.3,IBDXIFN,0)
  1. . S DIE="^DGCR(399,",DA=+$P(IB0,U,2),DR="215////"_+IB0 D ^DIE
  1. ;
  1. ; MRD;IB*2.0*516 - Added '$D check *before* removing the dangling
  1. ; pointers; and added code to 'shift' subsequent pointers, if any.
  1. ; If the entry was deleted, remove dangling pointers from #399.0304.
  1. I '$D(^IBA(362.3,IBDXIFN)) D
  1. . N IBPROC,IBPROCD,IBPIECE,IBHIT
  1. . S (IBHIT,IBPROC)=0
  1. . F S IBPROC=$O(^DGCR(399,IBIFN,"CP",IBPROC)) Q:'IBPROC S IBPROCD=$G(^(IBPROC,0)) I IBPROCD]"" D
  1. . . F IBPIECE=11:1:14 I +$P(IBPROCD,"^",IBPIECE)=IBDXIFN S IBHIT=1 D UPD^IBCU72("@",IBPIECE-1)
  1. . . Q
  1. . ;
  1. . ; If a pointer to the deleted DX code was found and removed, then
  1. . ; sound <bell>, display message, and 'shift' any other associated
  1. . ; DX codes to close the gap, if any.
  1. . I IBHIT D
  1. . . W *7,!,"This diagnosis was removed as a procedure diagnosis."
  1. . . ;
  1. . . S IBPROC=0
  1. . . F S IBPROC=$O(^DGCR(399,IBIFN,"CP",IBPROC)) Q:'IBPROC S IBPROCD=$G(^(IBPROC,0)) I IBPROCD]"" D
  1. . . . F IBPIECE=11:1:13 D
  1. . . . . ; If DX field is blank, and next one is not blank, then shift it 'up'.
  1. . . . . I $P(IBPROCD,"^",IBPIECE)="",$P(IBPROCD,"^",IBPIECE+1)'="" D
  1. . . . . . D UPD^IBCU72("@",IBPIECE) ; Delete from one slot...
  1. . . . . . D UPD^IBCU72($P(IBPROCD,"^",IBPIECE+1),IBPIECE-1) ; Add to the blank slot.
  1. . . . . . S IBPROCD=$G(^DGCR(399,IBIFN,"CP",IBPROC,0)) ; Grab updated version of this node.
  1. . . . . . Q
  1. . . . . Q
  1. . . . Q
  1. . . Q
  1. . Q
  1. ;
  1. EDITQ Q
  1. ;
  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
  1. ;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
  1. N CNT,IBX,IBY,IBZ,DIFN,IBC,ARR K DXARR,POARR S IBC="AIFN"_$G(IFN)
  1. S (CNT,IBX)=0 F S IBX=$O(^IBA(362.3,IBC,IBX)) Q:'IBX D
  1. . S DIFN=$O(^IBA(362.3,IBC,IBX,0)),IBY=$G(^IBA(362.3,DIFN,0)) Q:'IBY
  1. . S CNT=CNT+1,IBZ=+$P(IBY,U,3) I 'IBZ S IBZ=999+CNT
  1. . S DXARR(+IBY)=DIFN,ARR(IBZ)=+IBY_U_$P(IBY,U,3,4)
  1. S (IBX,IBY)=0 F S IBY=$O(ARR(IBY)) Q:'IBY S IBX=IBX+1,POARR(IBX)=ARR(IBY)
  1. S (DXARR,POARR)=$G(IFN)_"^"_CNT
  1. Q
  1. ;
  1. 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
  1. N IBX,IBY,IBZ,IBDATE,POA
  1. S IBDATE=$$BDATE^IBACSV(+$G(IBIFN)) ; The bill date of service
  1. W !!,?5,"----------------- Existing Diagnoses for Bill -----------------",!
  1. S IBX=0 F S IBX=$O(POARR(IBX)) Q:'IBX S IBZ=POARR(IBX),IBY=$$ICD9^IBACSV(+IBZ,IBDATE) D
  1. .S POA="" I $$INPAT^IBCEF(IBIFN),$$FT^IBCEF(IBIFN)=3 S POA=$P(IBZ,U,3) S:POA=1 POA="" S:POA'="" POA="("_POA_")"
  1. . W !,$P(IBY,U),?9,POA,?13,$P(IBY,U,3),?75,$S($P(IBZ,U,2)<1000:"("_$P(IBZ,U,2)_")",1:"")
  1. W !
  1. Q
  1. ;
  1. DISP1(IFN) ;
  1. I +$G(IFN) N POARR D SET(IFN,"",.POARR),DISP(.POARR)
  1. Q
  1. HELP ;called for help from dx enter to display existing dx's
  1. Q:'$G(IBIFN) N IBX
  1. D SET(IBIFN,.IBDXA,"") S IBX=$G(^DGCR(399,+IBIFN,0)) I IBX="" Q
  1. 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)
  1. D SET(IBIFN,.IBDXA,.IBPOA) D:+IBDXA DISP(.IBPOA)
  1. Q
  1. ;
  1. 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
  1. Q
  1. ;
  1. ; ******************************************************************************************
  1. ;
  1. DXOPT(IBIFN) ; display and ask user to select PCE diagnosis
  1. N IBDXA,IBOEDX,IBLIST,DFN,IBX
  1. D SET(IBIFN,.IBDXA,"")
  1. S DFN=$P($G(^DGCR(399,+IBIFN,0)),U,2),IBX=$G(^DGCR(399,+IBIFN,"U"))
  1. D OPTDX(DFN,$P(IBX,U,1),$P(IBX,U,2),.IBOEDX,.IBDXA),DISPOE(.IBOEDX,.IBDXA)
  1. I +$P($G(IBOEDX),U,2) D NEWDX(+IBOEDX) I $D(IBLIST) D ADDNEW(IBIFN,IBLIST,.IBOEDX)
  1. Q
  1. ;
  1. 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
  1. N IBDT,IBOE,IBDX,IBDXN,IBDXA,IBDXB,IBCNT,IBCNT1,ARR,IBI,IBJ,IBK,IBVAL,IBCBK
  1. K ARRAY
  1. S (IBCNT,IBCNT1)=0,DT1=$G(DT1)-.0001,DT2=$S(+$G(DT2):DT2,1:9999999)+.7999
  1. ;
  1. S IBVAL("DFN")=DFN,IBVAL("BDT")=DT1,IBVAL("EDT")=DT2
  1. S IBCBK="D OEDX^IBCU81(Y,.IBDXA,.IBDXB)"
  1. D SCAN^IBSDU("PATIENT/DATE",.IBVAL,"",IBCBK,1) K ^TMP("DIERR",$J)
  1. ;
  1. S (IBCNT,IBCNT1,IBI)=0 F S IBI=$O(IBDXA(IBI)) Q:'IBI D
  1. . S IBJ=0 F S IBJ=$O(IBDXA(IBI,IBJ)) Q:'IBJ D
  1. .. S IBK=0 F S IBK=$O(IBDXA(IBI,IBJ,IBK)) Q:'IBK D
  1. ... S IBDXN=0 F S IBDXN=$O(IBDXA(IBI,IBJ,IBK,IBDXN)) Q:'IBDXN D
  1. .... S IBDX=IBDXA(IBI,IBJ,IBK,IBDXN) I $D(ARR(+IBDX))!(+$P(IBDX,U,5)&(+$G(IBDXB(+IBDX)))) Q
  1. .... S IBCNT=IBCNT+1 I '$D(IBDXE(+IBDX)) S IBCNT1=IBCNT1+1
  1. .... S ARRAY(IBCNT)=IBDX S ARR(+IBDX)=""
  1. S ARRAY=IBCNT_"^"_IBCNT1 K IBDXA,IBDXB,ARR
  1. Q
  1. ;
  1. NEWDX(IBX) ; user select PCE diagnosis to add to bill
  1. Q:'$G(IBX) N X,Y,DIR,DIRUT K IBLIST W !
  1. 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."
  1. S DIR("?")="The diagnosis will be added to the bill with a print order corresponding to its position in this list."
  1. S DIR("A")="SELECT NEW DIAGNOSES TO ADD THE BILL"
  1. S DIR(0)="LO^1:"_+IBX D ^DIR K DIR G:'Y!$D(DIRUT) NEWDXE
  1. S IBLIST=Y
  1. ;
  1. S DIR("A")="YOU HAVE SELECTED "_IBLIST_" TO BE ADDED TO THE BILL IS THIS CORRECT",DIR("B")="YES"
  1. S DIR(0)="YO" D ^DIR K DIR I $D(DIRUT) K IBLIST G NEWDXE
  1. I 'Y G NEWDX1
  1. NEWDXE Q
  1. ;
  1. ADDNEW(IBIFN,LIST,IBOEA) ; add selected PCE diagnosis to bill
  1. Q:'LIST N IBI,IBX,IBDX,IBDT,IBQ,IBY,IBPIFN,IBZ
  1. F IBI=1:1 S IBX=$P(LIST,",",IBI) Q:'IBX I $D(IBOEA(IBX)) D
  1. . S IBDX=+IBOEA(IBX) I $D(^IBA(362.3,"AIFN"_IBIFN,IBDX)) Q
  1. . I $$ADD(IBDX,IBIFN) W "."
  1. Q
  1. ;
  1. DISPOE(OEARR,EXARR) ; display outpatient PCE diagnosis
  1. N IBCNT,IBDX,IBX,IBY,IBDATE
  1. W @IOF,!,"============================= DIAGNOSIS SCREEN ==============================",!
  1. S IBDATE=$$BDATE^IBACSV(+$G(IBIFN)) ; The bills date of service
  1. S IBCNT=0 F S IBCNT=$O(OEARR(IBCNT)) Q:'IBCNT D
  1. . S IBY=OEARR(IBCNT),IBDX=$$ICD9^IBACSV(+IBY,IBDATE)
  1. . S IBX="" I $D(EXARR(+OEARR(IBCNT))) S IBX="*"
  1. . W !,$J(IBCNT,2),")",?4,IBX,?5,$P(IBDX,U),?14,$E($P(IBDX,U,3),1,19)
  1. . I +$P(IBY,U,7) W ?35,$E($P($G(^SC(+$P(IBY,U,7),0)),U,1),1,15)
  1. . I $P(IBY,U,2)'="" W ?52,$E($$EXPAND^IBTRE(9000010.07,.12,$P(IBY,U,2)),1,3)
  1. . I $P(IBY,U,4)'="" W ?57,$$FMTE^XLFDT($E($P(IBY,U,4),1,12),2)
  1. . I $P(IBY,U,6)'="" W ?72,$E($P(IBY,U,6),1,7)
  1. Q
  1. ;
  1. 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
  1. ; Procedures (#304) sub-file of the Bill/Claims (#399) file.
  1. N I,X,IBY,Z
  1. S X=^(0),IBY=Y
  1. S I=$$PRCNM^IBCSCH1($P(X,U,1),$P(X,U,2)) W " ",$E($P(I,U,2)_$J("",27),1,27)
  1. S Z=$O(^DGCR(399,DA(1),"RC","ACP",+IBY,0))
  1. 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)
  1. 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)
  1. Q
  1. 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
  1. ; Check if the corresponding bill is for an inpatient episode, the
  1. ; admitting dx for the corresponding bill is null and the dx being
  1. ; entered is the first for the bill. If this is all true, admitting
  1. ; dx should be set to the dx.
  1. ;
  1. N OK,Z
  1. S Z=$G(^IBA(362.3,DA,0)),OK=0
  1. 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
  1. Q OK
  1. ;