- 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 Jan 18, 2025@03:21:28 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 ;