- 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
