IBCSC4E ;ALB/ARH - ADD/ENTER PTF/OE DIAGNOSIS ;3/2/94
;;2.0;INTEGRATED BILLING;**8,106,121,124,210,266,403,479,522**;21-MAR-94;Build 11
;;Per VA Directive 6402, this routine should not be modified.
;
DXINPT(IBIFN) ; display and ask user to select PTF diagnosis
N IBLIST,IBPTFDX
D PTFDSP(IBIFN),PTFASK I $D(IBLIST) D PTFADD(IBIFN,IBLIST) S POAEDIT=1
; get POA indicators from QuadraMed for UB-04 inpatient claims
I $$FT^IBCEF(IBIFN)=3 D SETPOA^IBCSC4F(IBIFN)
K ^TMP($J,"IBDX")
Q
;
PTFASK ;
D PTF Q:$G(IBPTFDX)'>0 N X,Y,DIR,DIRUT K IBLIST W !
PTFASK1 S DIR("A")="SELECT DIAGNOSIS FROM THE PTF RECORD TO INCLUDE ON THE BILL"
S DIR("?",1)="Enter the alphanumeric preceding the diagnosis you want added to the bill.",DIR("?",2)=""
S DIR("?",3)="To enter more than one separate them by a comma or within a movement use a"
S DIR("?",4)="range separated by a dash. * indicates the diagnosis is already on the bill."
S DIR("?")="The print order for each diagnosis will be determined by the order in this list."
S DIR(0)="FO^^D ITPTF^IBCSC4E" D ^DIR K DIR Q:$D(DIRUT)!(Y="")
;
S X=Y D ITPTF S IBLIST=X,DIR("A",1)="YOU HAVE SELECTED "_X_" TO BE ADDED TO THE BILL",DIR("A")="IS THIS CORRECT",DIR("B")="YES"
S DIR(0)="YO" D ^DIR K DIR I $D(DIRUT) K IBLIST Q
I 'Y K IBLIST G PTFASK1
Q
;
PTF ;
Q:'$D(^TMP($J,"IBDX","S")) N IBX,IBY,IBZ,IBORD,IBNUM K IBPTFDX S IBORD="",IBPTFDX=0
S IBX="" F S IBX=$O(^TMP($J,"IBDX","S",IBX)) Q:IBX="" D
. S IBZ=+$G(^TMP($J,"IBDX","S",IBX)) Q:'IBZ
. S IBORD=$E(IBX) Q:IBORD'?1A S IBNUM=+$E(IBX,2,999) Q:IBNUM'>0
. I IBNUM>$G(IBPTFDX(IBORD)) S IBPTFDX(IBORD)=IBNUM
. I '$D(^IBA(362.3,"AIFN"_+$G(IBIFN),+IBZ)) S IBPTFDX=IBPTFDX+1
Q
;
ITPTF ;
N IBI,IB1,IB2,IB3,IBJ,IBX,IBY,IBZ,IBA
S IBA="",IBX=X
F IBI=1:1 S IBY=$P(IBX,",",IBI) Q:IBY="" D Q:'$D(X) S X=IBA
. I IBY["-" S IBZ=$P(IBY,"-",1),IB2=$P(IBY,"-",2) D Q:'$D(X)
.. I $E(IBZ,1)'=$E(IB2,1) K X Q
.. S IBY="",IB1=$E(IBZ,2,999),IB2=$E(IB2,2,999),IBZ=$E(IBZ,1) I +IB2'>+IB1 K X Q
.. F IBJ=IB1:1:IB2 S IBY=IBY_IBZ_IBJ_"-" I IBJ>$G(IBPTFDX(IBZ)) Q
. F IBJ=1:1 S IB1=$P(IBY,"-",IBJ) Q:IB1="" S IB2=$E(IB1,1),IB3=$E(IB1,2,99) D Q:'$D(X)
.. I IB1'?1A1.3N K X Q
.. I IB2=""!'IB3 K X Q
.. I '$D(IBPTFDX(IB2)) K X Q
.. I IB3>+$G(IBPTFDX(IB2)) K X Q
.. S IBA=IBA_IB2_IB3_","
Q
;
PTFADD(IBIFN,LIST) ;
Q:'$D(^TMP($J,"IBDX","S"))!($G(LIST)="")!('$G(IBIFN)) N IBX,IBY,IBI,IBCD,IBDX
F IBI=1:1 S IBCD=$P(LIST,",",IBI) Q:IBCD="" D
. S IBDX=$G(^TMP($J,"IBDX","S",IBCD)) Q:'IBDX
. I ($$ICD9^IBACSV(+IBDX)'=""),'$D(^IBA(362.3,"AIFN"_IBIFN,+IBDX)) I $$ADD^IBCSC4D(+IBDX,IBIFN,$P(IBDX,U,3)) W "."
Q
;
PTFDSP(IBIFN) ; display PTF diagnosis within date range of the bill
; Output: ^TMP($J,"IBDX") as defined by PTFDXDT^IBCSC4F and
; ^TMP($J,"IBDX","S",x) = DIAGNOSIS w/x=selection identifer for a dx
N IB0,IBPTF,IBTF,IBU,IBFDT,IBTDT,IBDSCH,IBW,IBC,IBA,IBN,IBCNT,IBMCNT,IBMDT,IBMV,IBDT,IBLN,IBLABEL,IBDXCNT,IBI
N IBDX,IBID,IBON,IBY,IBMDRG,X,IBDATE,IBPOA,DIR,Y,IBMAXMV S IBMAXMV=0
;
K ^TMP($J,"IBDX") S IBW=41
;
S IBDATE=$$BDATE^IBACSV(IBIFN) ; The Event Date of the bill
S IB0=$G(^DGCR(399,+$G(IBIFN),0)),IBPTF=$P(IB0,U,8),IBTF=$P(IB0,U,6) Q:'$G(IBPTF)
S IBU=$G(^DGCR(399,+IBIFN,"U")),IBFDT=+IBU,IBTDT=$P(IBU,U,2) Q:$P(IB0,U,5)>2
;
D PTFDXDT^IBCSC4F(IBPTF,IBFDT,IBTDT,IBTF) S IBDSCH=$P(+$P($G(^TMP($J,"IBDX","M")),U,3),".")
;
F IBN="M","D" S (IBCNT,IBMCNT,IBMDT)="" F S IBMDT=$O(^TMP($J,"IBDX",IBN,IBMDT)) Q:'IBMDT D Q:IBMAXMV
. S IBMCNT=IBMCNT+1 S IBMCNT=$S(IBMCNT=27:33,IBMCNT=24:25,IBMCNT=56:57,1:IBMCNT) I IBMCNT>58 S IBMAXMV=1 Q
. ;
. S IBMV=$G(^TMP($J,"IBDX",IBN,IBMDT)),IBDT=+IBMV,IBMDRG=$P(IBMV,U,4)
. I IBN="M" S IBC=0,IBLABEL="Move",IBA=$C(64+IBMCNT) I 'IBDT S IBDT="D/C"
. I IBN="D" S IBC=41,IBLABEL="Discharge",IBA="X" I 'IBDT S IBDT="NOT DISCHARGED"
. ;
. S IBLN=IBLABEL_": "_$S(+IBDT:$P($$FMTE^XLFDT(+IBDT,2),"@",1),1:IBDT)
. S IBLN=IBLN_" "_$E($P($G(^DIC(42.4,+$P(IBMV,U,2),0)),U,1),1,12)
. S IBLN=IBLN_" "_$J("",(29-$L(IBLN)))_$S(+$P(IBMV,U,3):"<SC>",1:"<NSC>")
. ;
. S IBCNT=IBCNT+1,X(IBCNT)=$G(X(IBCNT))_$J("",IBW)
. S IBCNT=IBCNT+1,X(IBCNT)=$G(X(IBCNT))_$J("",IBW),X(IBCNT)=$E(X(IBCNT),1,IBC)_IBLN
. ;
. I '$O(^TMP($J,"IBDX",IBN,IBMDT,"")) S IBCNT=IBCNT+1,X(IBCNT)=$G(X(IBCNT))_$J("",IBW),X(IBCNT)=$E(X(IBCNT),1,IBC)_" No DX Codes Entered For "_IBLABEL
. ;
. S (IBDXCNT,IBI)="" F S IBI=$O(^TMP($J,"IBDX",IBN,IBMDT,IBI)) Q:'IBI D
.. S IBDX=^TMP($J,"IBDX",IBN,IBMDT,IBI),IBPOA=$P(IBDX,U,3),IBY=$$ICD9^IBACSV(+IBDX,IBDATE)
.. S IBDXCNT=IBDXCNT+1,IBID=IBA_IBDXCNT,IBON=" " I +$O(^IBA(362.3,"AIFN"_IBIFN,+IBDX,"")) S IBON="*"
.. S IBLN=" "_IBON_IBID_" - " S IBLN=IBLN_$J("",(8-$L(IBLN)))_$P(IBY,U,1) S IBLN=IBLN_$J("",(17-$L(IBLN)))_$E($P(IBY,U,3),1,22) I IBPOA'="" S $E(IBLN,36,39)=" ("_IBPOA_")"
.. S IBCNT=IBCNT+1,X(IBCNT)=$G(X(IBCNT))_$J("",IBW),X(IBCNT)=$E(X(IBCNT),1,IBC)_IBLN
.. S ^TMP($J,"IBDX","S",IBID)=IBDX
. ;
. I 'IBMDRG,IBN="M" S IBLN=" *** No DRG for Charges ***",IBCNT=IBCNT+1,X(IBCNT)=$G(X(IBCNT))_$J("",IBW),X(IBCNT)=$E(X(IBCNT),1,IBC)_IBLN
. I IBMDRG S IBLN=$P($$DRG^IBACSV(+IBMDRG,IBDATE),U,1)_" - "_$E($$DRGTD^IBACSV(+IBMDRG,IBDATE),1,30),IBCNT=IBCNT+1,X(IBCNT)=$G(X(IBCNT))_$J("",IBW),X(IBCNT)=$E(X(IBCNT),1,IBC)_IBLN
;
I IBDSCH,IBTDT<IBDSCH S IBCNT=2,X(IBCNT)=$G(X(IBCNT))_$J("",IBW),X(IBCNT)=$E(X(IBCNT),1,IBW)_"Discharge: "_$$FMTE^XLFDT(+$P(IBDSCH,"."),2)_" Not In Bill Range"
I 'IBDSCH,IBTDT<DT S IBCNT=2,X(IBCNT)=$G(X(IBCNT))_$J("",IBW),X(IBCNT)=$E(X(IBCNT),1,IBW)_"Discharge: NOT DISCHARGED"
;
I IBMAXMV S IBCNT=$O(X("A"),-1)+1 S X(IBCNT)="Maximum number of displayable movements exceeded."
;
W @IOF,"=============================== Diagnosis Screen ==============================="
S IBCNT=1,IBI="" F S IBI=$O(X(IBI)) Q:'IBI W !,$E(X(IBI),1,80) S IBCNT=IBCNT+1 I IBCNT>22 D S IBCNT=1 Q:'Y
. S DIR(0)="E" D ^DIR W !
Q
;
DELALL(IBIFN) ; ask/delete all diagnosis on a bill, including all CPT associated Diagnosis
Q:'$O(^IBA(362.3,"AIFN"_+$G(IBIFN),0))
;
N DIR,DIRUT,DUOUT,DTOUT,X,Y,DIK W !
S DIR("?")="Enter Yes to delete all Diagnosis currently defined for a bill, including any CPT Associated Diagnosis.",DIR("??")="^D DISP1^IBCSC4D("_IBIFN_")"
S DIR("A")="DELETE ALL DIAGNOSIS ON BILL, INCLUDING CPT ASSOCIATED DIAGNOSIS"
S DIR(0)="YO",DIR("B")="NO" D ^DIR K DIR Q:Y'=1
;
N IBPROC,IBPROCD,IBXRF,IBDX,IBDXI,DIE,DIC,DA,DR
S IBPROC=0 F S IBPROC=$O(^DGCR(399,IBIFN,"CP",IBPROC)) Q:'IBPROC D
. S IBPROCD=$G(^DGCR(399,IBIFN,"CP",IBPROC,0)) I "^^^"[$P(IBPROCD,U,11,14) Q
. S DIE="^DGCR(399,"_IBIFN_",""CP"",",DA=IBPROC,DA(1)=IBIFN,DR="10///@;11///@;12///@;13///@" D ^DIE K DA,DIE,DR
;
S IBXRF="AIFN"_+IBIFN
S IBDX=0 F S IBDX=$O(^IBA(362.3,IBXRF,IBDX)) Q:'IBDX D
. S IBDXI=0 F S IBDXI=$O(^IBA(362.3,IBXRF,IBDX,IBDXI)) Q:'IBDXI D
.. S DIK="^IBA(362.3,",DA=IBDXI D ^DIK K DIK,DA
W " .... deleted"
Q
;
POAASK ; POA edit
N DIR,DIRUT,DUOUT,DTOUT,DX,ORD,X,Y
W !
S DIR("?")="Enter Yes to edit POA indicators."
S DIR("A")="Edit POA indicators"
S DIR(0)="YO",DIR("B")="NO" D ^DIR K DIR Q:Y'=1
S DIE="^IBA(362.3,",ORD="" F S ORD=$O(^IBA(362.3,"AO",IBIFN,ORD)) Q:ORD="" D Q:$D(Y) ;
.S DA=$O(^IBA(362.3,"AO",IBIFN,ORD,"")),DX=$$GET1^DIQ(362.3,DA,.01),DR=".04 "_DX D ^DIE
.Q
K DA,DIE,DIR,DR
D CLEAN^DILF
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCSC4E 7385 printed Dec 13, 2024@02:20:17 Page 2
IBCSC4E ;ALB/ARH - ADD/ENTER PTF/OE DIAGNOSIS ;3/2/94
+1 ;;2.0;INTEGRATED BILLING;**8,106,121,124,210,266,403,479,522**;21-MAR-94;Build 11
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
DXINPT(IBIFN) ; display and ask user to select PTF diagnosis
+1 NEW IBLIST,IBPTFDX
+2 DO PTFDSP(IBIFN)
DO PTFASK
IF $DATA(IBLIST)
DO PTFADD(IBIFN,IBLIST)
SET POAEDIT=1
+3 ; get POA indicators from QuadraMed for UB-04 inpatient claims
+4 IF $$FT^IBCEF(IBIFN)=3
DO SETPOA^IBCSC4F(IBIFN)
+5 KILL ^TMP($JOB,"IBDX")
+6 QUIT
+7 ;
PTFASK ;
+1 DO PTF
if $GET(IBPTFDX)'>0
QUIT
NEW X,Y,DIR,DIRUT
KILL IBLIST
WRITE !
PTFASK1 SET DIR("A")="SELECT DIAGNOSIS FROM THE PTF RECORD TO INCLUDE ON THE BILL"
+1 SET DIR("?",1)="Enter the alphanumeric preceding the diagnosis you want added to the bill."
SET DIR("?",2)=""
+2 SET DIR("?",3)="To enter more than one separate them by a comma or within a movement use a"
+3 SET DIR("?",4)="range separated by a dash. * indicates the diagnosis is already on the bill."
+4 SET DIR("?")="The print order for each diagnosis will be determined by the order in this list."
+5 SET DIR(0)="FO^^D ITPTF^IBCSC4E"
DO ^DIR
KILL DIR
if $DATA(DIRUT)!(Y="")
QUIT
+6 ;
+7 SET X=Y
DO ITPTF
SET IBLIST=X
SET DIR("A",1)="YOU HAVE SELECTED "_X_" TO BE ADDED TO THE BILL"
SET DIR("A")="IS THIS CORRECT"
SET DIR("B")="YES"
+8 SET DIR(0)="YO"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
KILL IBLIST
QUIT
+9 IF 'Y
KILL IBLIST
GOTO PTFASK1
+10 QUIT
+11 ;
PTF ;
+1 if '$DATA(^TMP($JOB,"IBDX","S"))
QUIT
NEW IBX,IBY,IBZ,IBORD,IBNUM
KILL IBPTFDX
SET IBORD=""
SET IBPTFDX=0
+2 SET IBX=""
FOR
SET IBX=$ORDER(^TMP($JOB,"IBDX","S",IBX))
if IBX=""
QUIT
Begin DoDot:1
+3 SET IBZ=+$GET(^TMP($JOB,"IBDX","S",IBX))
if 'IBZ
QUIT
+4 SET IBORD=$EXTRACT(IBX)
if IBORD'?1A
QUIT
SET IBNUM=+$EXTRACT(IBX,2,999)
if IBNUM'>0
QUIT
+5 IF IBNUM>$GET(IBPTFDX(IBORD))
SET IBPTFDX(IBORD)=IBNUM
+6 IF '$DATA(^IBA(362.3,"AIFN"_+$GET(IBIFN),+IBZ))
SET IBPTFDX=IBPTFDX+1
End DoDot:1
+7 QUIT
+8 ;
ITPTF ;
+1 NEW IBI,IB1,IB2,IB3,IBJ,IBX,IBY,IBZ,IBA
+2 SET IBA=""
SET IBX=X
+3 FOR IBI=1:1
SET IBY=$PIECE(IBX,",",IBI)
if IBY=""
QUIT
Begin DoDot:1
+4 IF IBY["-"
SET IBZ=$PIECE(IBY,"-",1)
SET IB2=$PIECE(IBY,"-",2)
Begin DoDot:2
+5 IF $EXTRACT(IBZ,1)'=$EXTRACT(IB2,1)
KILL X
QUIT
+6 SET IBY=""
SET IB1=$EXTRACT(IBZ,2,999)
SET IB2=$EXTRACT(IB2,2,999)
SET IBZ=$EXTRACT(IBZ,1)
IF +IB2'>+IB1
KILL X
QUIT
+7 FOR IBJ=IB1:1:IB2
SET IBY=IBY_IBZ_IBJ_"-"
IF IBJ>$GET(IBPTFDX(IBZ))
QUIT
End DoDot:2
if '$DATA(X)
QUIT
+8 FOR IBJ=1:1
SET IB1=$PIECE(IBY,"-",IBJ)
if IB1=""
QUIT
SET IB2=$EXTRACT(IB1,1)
SET IB3=$EXTRACT(IB1,2,99)
Begin DoDot:2
+9 IF IB1'?1A1.3N
KILL X
QUIT
+10 IF IB2=""!'IB3
KILL X
QUIT
+11 IF '$DATA(IBPTFDX(IB2))
KILL X
QUIT
+12 IF IB3>+$GET(IBPTFDX(IB2))
KILL X
QUIT
+13 SET IBA=IBA_IB2_IB3_","
End DoDot:2
if '$DATA(X)
QUIT
End DoDot:1
if '$DATA(X)
QUIT
SET X=IBA
+14 QUIT
+15 ;
PTFADD(IBIFN,LIST) ;
+1 if '$DATA(^TMP($JOB,"IBDX","S"))!($GET(LIST)="")!('$GET(IBIFN))
QUIT
NEW IBX,IBY,IBI,IBCD,IBDX
+2 FOR IBI=1:1
SET IBCD=$PIECE(LIST,",",IBI)
if IBCD=""
QUIT
Begin DoDot:1
+3 SET IBDX=$GET(^TMP($JOB,"IBDX","S",IBCD))
if 'IBDX
QUIT
+4 IF ($$ICD9^IBACSV(+IBDX)'="")
IF '$DATA(^IBA(362.3,"AIFN"_IBIFN,+IBDX))
IF $$ADD^IBCSC4D(+IBDX,IBIFN,$PIECE(IBDX,U,3))
WRITE "."
End DoDot:1
+5 QUIT
+6 ;
PTFDSP(IBIFN) ; display PTF diagnosis within date range of the bill
+1 ; Output: ^TMP($J,"IBDX") as defined by PTFDXDT^IBCSC4F and
+2 ; ^TMP($J,"IBDX","S",x) = DIAGNOSIS w/x=selection identifer for a dx
+3 NEW IB0,IBPTF,IBTF,IBU,IBFDT,IBTDT,IBDSCH,IBW,IBC,IBA,IBN,IBCNT,IBMCNT,IBMDT,IBMV,IBDT,IBLN,IBLABEL,IBDXCNT,IBI
+4 NEW IBDX,IBID,IBON,IBY,IBMDRG,X,IBDATE,IBPOA,DIR,Y,IBMAXMV
SET IBMAXMV=0
+5 ;
+6 KILL ^TMP($JOB,"IBDX")
SET IBW=41
+7 ;
+8 ; The Event Date of the bill
SET IBDATE=$$BDATE^IBACSV(IBIFN)
+9 SET IB0=$GET(^DGCR(399,+$GET(IBIFN),0))
SET IBPTF=$PIECE(IB0,U,8)
SET IBTF=$PIECE(IB0,U,6)
if '$GET(IBPTF)
QUIT
+10 SET IBU=$GET(^DGCR(399,+IBIFN,"U"))
SET IBFDT=+IBU
SET IBTDT=$PIECE(IBU,U,2)
if $PIECE(IB0,U,5)>2
QUIT
+11 ;
+12 DO PTFDXDT^IBCSC4F(IBPTF,IBFDT,IBTDT,IBTF)
SET IBDSCH=$PIECE(+$PIECE($GET(^TMP($JOB,"IBDX","M")),U,3),".")
+13 ;
+14 FOR IBN="M","D"
SET (IBCNT,IBMCNT,IBMDT)=""
FOR
SET IBMDT=$ORDER(^TMP($JOB,"IBDX",IBN,IBMDT))
if 'IBMDT
QUIT
Begin DoDot:1
+15 SET IBMCNT=IBMCNT+1
SET IBMCNT=$SELECT(IBMCNT=27:33,IBMCNT=24:25,IBMCNT=56:57,1:IBMCNT)
IF IBMCNT>58
SET IBMAXMV=1
QUIT
+16 ;
+17 SET IBMV=$GET(^TMP($JOB,"IBDX",IBN,IBMDT))
SET IBDT=+IBMV
SET IBMDRG=$PIECE(IBMV,U,4)
+18 IF IBN="M"
SET IBC=0
SET IBLABEL="Move"
SET IBA=$CHAR(64+IBMCNT)
IF 'IBDT
SET IBDT="D/C"
+19 IF IBN="D"
SET IBC=41
SET IBLABEL="Discharge"
SET IBA="X"
IF 'IBDT
SET IBDT="NOT DISCHARGED"
+20 ;
+21 SET IBLN=IBLABEL_": "_$SELECT(+IBDT:$PIECE($$FMTE^XLFDT(+IBDT,2),"@",1),1:IBDT)
+22 SET IBLN=IBLN_" "_$EXTRACT($PIECE($GET(^DIC(42.4,+$PIECE(IBMV,U,2),0)),U,1),1,12)
+23 SET IBLN=IBLN_" "_$JUSTIFY("",(29-$LENGTH(IBLN)))_$SELECT(+$PIECE(IBMV,U,3):"<SC>",1:"<NSC>")
+24 ;
+25 SET IBCNT=IBCNT+1
SET X(IBCNT)=$GET(X(IBCNT))_$JUSTIFY("",IBW)
+26 SET IBCNT=IBCNT+1
SET X(IBCNT)=$GET(X(IBCNT))_$JUSTIFY("",IBW)
SET X(IBCNT)=$EXTRACT(X(IBCNT),1,IBC)_IBLN
+27 ;
+28 IF '$ORDER(^TMP($JOB,"IBDX",IBN,IBMDT,""))
SET IBCNT=IBCNT+1
SET X(IBCNT)=$GET(X(IBCNT))_$JUSTIFY("",IBW)
SET X(IBCNT)=$EXTRACT(X(IBCNT),1,IBC)_" No DX Codes Entered For "_IBLABEL
+29 ;
+30 SET (IBDXCNT,IBI)=""
FOR
SET IBI=$ORDER(^TMP($JOB,"IBDX",IBN,IBMDT,IBI))
if 'IBI
QUIT
Begin DoDot:2
+31 SET IBDX=^TMP($JOB,"IBDX",IBN,IBMDT,IBI)
SET IBPOA=$PIECE(IBDX,U,3)
SET IBY=$$ICD9^IBACSV(+IBDX,IBDATE)
+32 SET IBDXCNT=IBDXCNT+1
SET IBID=IBA_IBDXCNT
SET IBON=" "
IF +$ORDER(^IBA(362.3,"AIFN"_IBIFN,+IBDX,""))
SET IBON="*"
+33 SET IBLN=" "_IBON_IBID_" - "
SET IBLN=IBLN_$JUSTIFY("",(8-$LENGTH(IBLN)))_$PIECE(IBY,U,1)
SET IBLN=IBLN_$JUSTIFY("",(17-$LENGTH(IBLN)))_$EXTRACT($PIECE(IBY,U,3),1,22)
IF IBPOA'=""
SET $EXTRACT(IBLN,36,39)=" ("_IBPOA_")"
+34 SET IBCNT=IBCNT+1
SET X(IBCNT)=$GET(X(IBCNT))_$JUSTIFY("",IBW)
SET X(IBCNT)=$EXTRACT(X(IBCNT),1,IBC)_IBLN
+35 SET ^TMP($JOB,"IBDX","S",IBID)=IBDX
End DoDot:2
+36 ;
+37 IF 'IBMDRG
IF IBN="M"
SET IBLN=" *** No DRG for Charges ***"
SET IBCNT=IBCNT+1
SET X(IBCNT)=$GET(X(IBCNT))_$JUSTIFY("",IBW)
SET X(IBCNT)=$EXTRACT(X(IBCNT),1,IBC)_IBLN
+38 IF IBMDRG
SET IBLN=$PIECE($$DRG^IBACSV(+IBMDRG,IBDATE),U,1)_" - "_$EXTRACT($$DRGTD^IBACSV(+IBMDRG,IBDATE),1,30)
SET IBCNT=IBCNT+1
SET X(IBCNT)=$GET(X(IBCNT))_$JUSTIFY("",IBW)
SET X(IBCNT)=$EXTRACT(X(IBCNT),1,IBC)_IBLN
End DoDot:1
if IBMAXMV
QUIT
+39 ;
+40 IF IBDSCH
IF IBTDT<IBDSCH
SET IBCNT=2
SET X(IBCNT)=$GET(X(IBCNT))_$JUSTIFY("",IBW)
SET X(IBCNT)=$EXTRACT(X(IBCNT),1,IBW)_"Discharge: "_$$FMTE^XLFDT(+$PIECE(IBDSCH,"."),2)_" Not In Bill Range"
+41 IF 'IBDSCH
IF IBTDT<DT
SET IBCNT=2
SET X(IBCNT)=$GET(X(IBCNT))_$JUSTIFY("",IBW)
SET X(IBCNT)=$EXTRACT(X(IBCNT),1,IBW)_"Discharge: NOT DISCHARGED"
+42 ;
+43 IF IBMAXMV
SET IBCNT=$ORDER(X("A"),-1)+1
SET X(IBCNT)="Maximum number of displayable movements exceeded."
+44 ;
+45 WRITE @IOF,"=============================== Diagnosis Screen ==============================="
+46 SET IBCNT=1
SET IBI=""
FOR
SET IBI=$ORDER(X(IBI))
if 'IBI
QUIT
WRITE !,$EXTRACT(X(IBI),1,80)
SET IBCNT=IBCNT+1
IF IBCNT>22
Begin DoDot:1
+47 SET DIR(0)="E"
DO ^DIR
WRITE !
End DoDot:1
SET IBCNT=1
if 'Y
QUIT
+48 QUIT
+49 ;
DELALL(IBIFN) ; ask/delete all diagnosis on a bill, including all CPT associated Diagnosis
+1 if '$ORDER(^IBA(362.3,"AIFN"_+$GET(IBIFN),0))
QUIT
+2 ;
+3 NEW DIR,DIRUT,DUOUT,DTOUT,X,Y,DIK
WRITE !
+4 SET DIR("?")="Enter Yes to delete all Diagnosis currently defined for a bill, including any CPT Associated Diagnosis."
SET DIR("??")="^D DISP1^IBCSC4D("_IBIFN_")"
+5 SET DIR("A")="DELETE ALL DIAGNOSIS ON BILL, INCLUDING CPT ASSOCIATED DIAGNOSIS"
+6 SET DIR(0)="YO"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
if Y'=1
QUIT
+7 ;
+8 NEW IBPROC,IBPROCD,IBXRF,IBDX,IBDXI,DIE,DIC,DA,DR
+9 SET IBPROC=0
FOR
SET IBPROC=$ORDER(^DGCR(399,IBIFN,"CP",IBPROC))
if 'IBPROC
QUIT
Begin DoDot:1
+10 SET IBPROCD=$GET(^DGCR(399,IBIFN,"CP",IBPROC,0))
IF "^^^"[$PIECE(IBPROCD,U,11,14)
QUIT
+11 SET DIE="^DGCR(399,"_IBIFN_",""CP"","
SET DA=IBPROC
SET DA(1)=IBIFN
SET DR="10///@;11///@;12///@;13///@"
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+12 ;
+13 SET IBXRF="AIFN"_+IBIFN
+14 SET IBDX=0
FOR
SET IBDX=$ORDER(^IBA(362.3,IBXRF,IBDX))
if 'IBDX
QUIT
Begin DoDot:1
+15 SET IBDXI=0
FOR
SET IBDXI=$ORDER(^IBA(362.3,IBXRF,IBDX,IBDXI))
if 'IBDXI
QUIT
Begin DoDot:2
+16 SET DIK="^IBA(362.3,"
SET DA=IBDXI
DO ^DIK
KILL DIK,DA
End DoDot:2
End DoDot:1
+17 WRITE " .... deleted"
+18 QUIT
+19 ;
POAASK ; POA edit
+1 NEW DIR,DIRUT,DUOUT,DTOUT,DX,ORD,X,Y
+2 WRITE !
+3 SET DIR("?")="Enter Yes to edit POA indicators."
+4 SET DIR("A")="Edit POA indicators"
+5 SET DIR(0)="YO"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
if Y'=1
QUIT
+6 ;
SET DIE="^IBA(362.3,"
SET ORD=""
FOR
SET ORD=$ORDER(^IBA(362.3,"AO",IBIFN,ORD))
if ORD=""
QUIT
Begin DoDot:1
+7 SET DA=$ORDER(^IBA(362.3,"AO",IBIFN,ORD,""))
SET DX=$$GET1^DIQ(362.3,DA,.01)
SET DR=".04 "_DX
DO ^DIE
+8 QUIT
End DoDot:1
if $DATA(Y)
QUIT
+9 KILL DA,DIE,DIR,DR
+10 DO CLEAN^DILF
+11 QUIT
