IBCSC4E ;ALB/ARH - ADD/ENTER PTF/OE DIAGNOSIS ; 3/2/94
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;
;
PTFASK ;
D PTF Q:$G(IBPTFDX)'>0 N X,Y 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 range separated by a dash.",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 G PTFASK1
Q
;
PTF ;
Q:'$D(^UTILITY($J,"IBDX")) N IBX,IBY,IBZ,IBORD K IBPTFDX S IBORD="",IBPTFDX=0
S IBX=0 F S IBX=$O(^UTILITY($J,"IBDX",IBX)) Q:'IBX S IBY=0 F S IBY=$O(^UTILITY($J,"IBDX",IBX,IBY)) Q:'IBY D
. S IBZ=^UTILITY($J,"IBDX",IBX,IBY) I IBY=1 S IBORD=$P(IBZ,U,3)
. I IBORD'="" S IBPTFDX(IBORD)=IBY I '$D(^IBA(362.3,"AIFN"_+$G(IBIFN),+IBZ)) S IBPTFDX=IBPTFDX+1
Q
;
ITPTF ;
N IBI,IB1,IB2,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 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(^UTILITY($J,"IBDX"))!($G(LIST)="")!('$G(IBIFN)) N IBX,IBY,IBI,IBCD,IB1,IB2
F IBI=1:1 S IBCD=$P(LIST,",",IBI) Q:IBCD="" D
. S IB1=$E(IBCD,1),IB2=$E(IBCD,2,999) Q:IB1=""!'IB2
. S IBX=0 F S IBX=$O(^UTILITY($J,"IBDX",IBX)) Q:'IBX D
.. I $P($G(^UTILITY($J,"IBDX",IBX,1)),U,3)=IB1 S IBDX=$P($G(^UTILITY($J,"IBDX",IBX,IB2)),U,1) I '$D(^IBA(362.3,"AIFN"_IBIFN,IBDX)) I $$ADD^IBCSC4D(IBDX,IBIFN) W "."
Q
;
NEWDX(IBX) ;
Q:'$G(IBX) N X,Y 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) ;
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^IBCSC4D(IBDX,IBIFN) W "."
Q
IBCSC4E ;ALB/ARH - ADD/ENTER PTF/OE DIAGNOSIS ; 3/2/94
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;
+5 ;
PTFASK ;
+1 DO PTF
IF $GET(IBPTFDX)'>0
QUIT
NEW X,Y
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 range separated by a dash."
SET DIR("?")="The print order for each diagnosis will be determined by the order in this list."
+3 SET DIR(0)="FO^^D ITPTF^IBCSC4E"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)!(Y="")
QUIT
+4 ;
+5 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"
+6 SET DIR(0)="YO"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
KILL IBLIST
QUIT
+7 IF 'Y
GOTO PTFASK1
+8 QUIT
+9 ;
PTF ;
+1 IF '$DATA(^UTILITY($JOB,"IBDX"))
QUIT
NEW IBX,IBY,IBZ,IBORD
KILL IBPTFDX
SET IBORD=""
SET IBPTFDX=0
+2 SET IBX=0
FOR
SET IBX=$ORDER(^UTILITY($JOB,"IBDX",IBX))
IF 'IBX
QUIT
SET IBY=0
FOR
SET IBY=$ORDER(^UTILITY($JOB,"IBDX",IBX,IBY))
IF 'IBY
QUIT
Begin DoDot:1
+3 SET IBZ=^UTILITY($JOB,"IBDX",IBX,IBY)
IF IBY=1
SET IBORD=$PIECE(IBZ,U,3)
+4 IF IBORD'=""
SET IBPTFDX(IBORD)=IBY
IF '$DATA(^IBA(362.3,"AIFN"_+$GET(IBIFN),+IBZ))
SET IBPTFDX=IBPTFDX+1
End DoDot:1
+5 QUIT
+6 ;
ITPTF ;
+1 NEW IBI,IB1,IB2,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 IB2=""!'IB3
KILL X
QUIT
+10 IF '$DATA(IBPTFDX(IB2))
KILL X
QUIT
+11 IF IB3>+$GET(IBPTFDX(IB2))
KILL X
QUIT
+12 SET IBA=IBA_IB2_IB3_","
End DoDot:2
IF '$DATA(X)
QUIT
End DoDot:1
IF '$DATA(X)
QUIT
SET X=IBA
+13 QUIT
+14 ;
PTFADD(IBIFN,LIST) ;
+1 IF '$DATA(^UTILITY($JOB,"IBDX"))!($GET(LIST)="")!('$GET(IBIFN))
QUIT
NEW IBX,IBY,IBI,IBCD,IB1,IB2
+2 FOR IBI=1:1
SET IBCD=$PIECE(LIST,",",IBI)
IF IBCD=""
QUIT
Begin DoDot:1
+3 SET IB1=$EXTRACT(IBCD,1)
SET IB2=$EXTRACT(IBCD,2,999)
IF IB1=""!'IB2
QUIT
+4 SET IBX=0
FOR
SET IBX=$ORDER(^UTILITY($JOB,"IBDX",IBX))
IF 'IBX
QUIT
Begin DoDot:2
+5 IF $PIECE($GET(^UTILITY($JOB,"IBDX",IBX,1)),U,3)=IB1
SET IBDX=$PIECE($GET(^UTILITY($JOB,"IBDX",IBX,IB2)),U,1)
IF '$DATA(^IBA(362.3,"AIFN"_IBIFN,IBDX))
IF $$ADD^IBCSC4D(IBDX,IBIFN)
WRITE "."
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
NEWDX(IBX) ;
+1 IF '$GET(IBX)
QUIT
NEW X,Y
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) ;
+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^IBCSC4D(IBDX,IBIFN)
WRITE "."
End DoDot:1
+5 QUIT
