IBCSC4D.m

IBCSC4D	;ALB/ARH - ADD/ENTER DIAGNOSIS  ; 11/9/93

	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

	;;Per VHA Directive 10-93-142, this routine should not be modified.

	;

	;

EN	;add/edit diagnosis for a bill, IBIFN required

	S IBX=$G(^DGCR(399,+IBIFN,0)) D SET(IBIFN,.IBDXA,"")

	I $P(IBX,U,5)<3 D PTFASK^IBCSC4E I $D(IBLIST) D PTFADD^IBCSC4E(IBIFN,IBLIST)

	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)

	I +$P($G(IBOEDX),U,2) D NEWDX^IBCSC4E(+IBOEDX) I $D(IBLIST) D ADDNEW^IBCSC4E(IBIFN,IBLIST,.IBOEDX)

	S IBDIFN=0 D SET(IBIFN,.IBDXA,.IBPOA) D:+IBDXA DISP(.IBPOA)

E1	S IBDX=$$ASKDX I +IBDX>0 S IBDIFN=+$G(IBDXA(+IBDX)) S:'IBDIFN IBDIFN=$$ADD(+IBDX,IBIFN) I +IBDIFN>0 D EDIT(+IBDIFN) D SET(IBIFN,.IBDXA,.IBPOA) G E1

	;

EXIT	K IBDIFN,IBDXA,IBPOA,IBDX,IBX,IBOEDX,IBLIST

	Q

	;

ASKDX()	;

	N X,Y

	;S DIR("A")="Select ICD DIAGNOSIS",DIR(0)="362.3,.01O" D ^DIR K DIR

AD	S DIR("??")="^D HELP^IBCSC4D",DIR("?",1)="Enter a diagnosis for this bill.  Duplicates are not allowed.",DIR("?")="Only active diagnosis, no duplicates for a bill, and bill must not be authorized or cancelled."

	S DIR(0)="PO^80:EAMQ" D ^DIR K DIR I Y>0,'$D(IBDXA(+Y)),+$P($G(^ICD9(+Y,0)),U,9) W " ... dx inactive." G AD

	Q Y

	;

ADD(DX,IFN)	;

	S DIC="^IBA(362.3,",DIC(0)="AQL",DIC("DR")=".02////"_IFN,X=DX K DA,DO D FILE^DICN K DA,DO,DIC,X

	Q Y

	;

EDIT(DIFN)	;

	S DIDEL=362.3,DIE="^IBA(362.3,",DR=".01;.03",DA=DIFN D ^DIE K DIE,DR,DA,DIC,DIDEL

	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,  (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_"^"_$P(IBY,U,3)

	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

	W !!,?5,"-----------------  Existing Diagnoses for Bill  -----------------",!

	S IBX=0 F  S IBX=$O(POARR(IBX)) Q:'IBX  S IBZ=POARR(IBX),IBY=$G(^ICD9(+IBZ,0)) D

	. W !,?12,$P(IBY,U,1),?26,$P(IBY,U,3),?60,$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

	;

OPTDX(DFN,DT1,DT2,ARRAY,IBDXA)	;

	N IBDT,IBOE,IBDX,IBCNT,IBCNT1,ARR K ARRAY S (IBCNT,IBCNT1)=0,DT1=$G(DT1)-.0001,DT2=$S(+$G(DT2):DT2,1:9999999)+.7999

	S IBDT=DT1 F  S IBDT=$O(^SCE("ADFN",DFN,IBDT)) Q:'IBDT!(IBDT>DT2)  D

	. S IBOE=0 F  S IBOE=$O(^SCE("ADFN",DFN,IBDT,IBOE)) Q:'IBOE  D

	.. S IBDX=0 F  S IBDX=$O(^SDD(409.43,"AO",IBOE,IBDX)) Q:'IBDX  D

	... I '$D(ARR(IBDX)) S IBCNT=IBCNT+1,ARRAY(IBCNT)=IBDX,ARR(IBDX)="" I '$D(IBDXA(IBDX)) S IBCNT1=IBCNT1+1

	S ARRAY=IBCNT_"^"_IBCNT1

	Q

	;

DISPOE(OEARR,EXARR)	;

	N IBCNT,IBDX,IBX  W @IOF,!,"============================= DIAGNOSIS SCREEN ==============================",!

	S IBCNT=0 F  S IBCNT=$O(OEARR(IBCNT)) Q:'IBCNT  S IBDX=$G(^ICD9(+OEARR(IBCNT),0)) D

	. S IBX="" I $D(EXARR(+OEARR(IBCNT))) S IBX="*"

	. W !,$J(IBCNT,2),")",?11,IBX,?12,$P(IBDX,U,1),?26,$P(IBDX,U,3)

	Q

IBCSC4D   ;ALB/ARH - ADD/ENTER DIAGNOSIS  ; 11/9/93

 +1       ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

 +4       ;

EN        ;add/edit diagnosis for a bill, IBIFN required

 +1        SET IBX=$GET(^DGCR(399,+IBIFN,0))

           DO SET(IBIFN,.IBDXA,"")

 +2        IF $PIECE(IBX,U,5)<3

               DO PTFASK^IBCSC4E

               IF $DATA(IBLIST)

                   DO PTFADD^IBCSC4E(IBIFN,IBLIST)

 +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        IF +$PIECE($GET(IBOEDX),U,2)

               DO NEWDX^IBCSC4E(+IBOEDX)

               IF $DATA(IBLIST)

                   DO ADDNEW^IBCSC4E(IBIFN,IBLIST,.IBOEDX)

 +5        SET IBDIFN=0

           DO SET(IBIFN,.IBDXA,.IBPOA)

           IF +IBDXA

               DO DISP(.IBPOA)

E1         SET IBDX=$$ASKDX

           IF +IBDX>0

               SET IBDIFN=+$GET(IBDXA(+IBDX))

               IF 'IBDIFN

                   SET IBDIFN=$$ADD(+IBDX,IBIFN)

               IF +IBDIFN>0

                   DO EDIT(+IBDIFN)

                   DO SET(IBIFN,.IBDXA,.IBPOA)

                   GOTO E1

 +1       ;

EXIT       KILL IBDIFN,IBDXA,IBPOA,IBDX,IBX,IBOEDX,IBLIST

 +1        QUIT 

 +2       ;

ASKDX()   ;

 +1        NEW X,Y

 +2       ;S DIR("A")="Select ICD DIAGNOSIS",DIR(0)="362.3,.01O" D ^DIR K DIR

AD         SET DIR("??")="^D HELP^IBCSC4D"

           SET DIR("?",1)="Enter a diagnosis for this bill.  Duplicates are not allowed."

           SET DIR("?")="Only active diagnosis, no duplicates for a bill, and bill must not be authorized or cancelled."

 +1        SET DIR(0)="PO^80:EAMQ"

           DO ^DIR

           KILL DIR

           IF Y>0

               IF '$DATA(IBDXA(+Y))

                   IF +$PIECE($GET(^ICD9(+Y,0)),U,9)

                       WRITE " ... dx inactive."

                       GOTO AD

 +2        QUIT Y

 +3       ;

ADD(DX,IFN) ;

 +1        SET DIC="^IBA(362.3,"

           SET DIC(0)="AQL"

           SET DIC("DR")=".02////"_IFN

           SET X=DX

           KILL DA,DO

           DO FILE^DICN

           KILL DA,DO,DIC,X

 +2        QUIT Y

 +3       ;

EDIT(DIFN) ;

 +1        SET DIDEL=362.3

           SET DIE="^IBA(362.3,"

           SET DR=".01;.03"

           SET DA=DIFN

           DO ^DIE

           KILL DIE,DR,DA,DIC,DIDEL

 +2        QUIT 

 +3       ;

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,  (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_"^"_$PIECE(IBY,U,3)

               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

 +3        WRITE !!,?5,"-----------------  Existing Diagnoses for Bill  -----------------",!

 +4        SET IBX=0

           FOR 

               SET IBX=$ORDER(POARR(IBX))

               IF 'IBX

                   QUIT 

               SET IBZ=POARR(IBX)

               SET IBY=$GET(^ICD9(+IBZ,0))

               Begin DoDot:1

 +5                WRITE !,?12,$PIECE(IBY,U,1),?26,$PIECE(IBY,U,3),?60,$SELECT($PIECE(IBZ,U,2)<1000:"("_$PIECE(IBZ,U,2)_")",1:"")

               End DoDot:1

 +6        WRITE !

 +7        QUIT 

 +8       ;

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       ;

OPTDX(DFN,DT1,DT2,ARRAY,IBDXA) ;

 +1        NEW IBDT,IBOE,IBDX,IBCNT,IBCNT1,ARR

           KILL ARRAY

           SET (IBCNT,IBCNT1)=0

           SET DT1=$GET(DT1)-.0001

           SET DT2=$SELECT(+$GET(DT2):DT2,1:9999999)+.7999

 +2        SET IBDT=DT1

           FOR 

               SET IBDT=$ORDER(^SCE("ADFN",DFN,IBDT))

               IF 'IBDT!(IBDT>DT2)

                   QUIT 

               Begin DoDot:1

 +3                SET IBOE=0

                   FOR 

                       SET IBOE=$ORDER(^SCE("ADFN",DFN,IBDT,IBOE))

                       IF 'IBOE

                           QUIT 

                       Begin DoDot:2

 +4                        SET IBDX=0

                           FOR 

                               SET IBDX=$ORDER(^SDD(409.43,"AO",IBOE,IBDX))

                               IF 'IBDX

                                   QUIT 

                               Begin DoDot:3

 +5                                IF '$DATA(ARR(IBDX))

                                       SET IBCNT=IBCNT+1

                                       SET ARRAY(IBCNT)=IBDX

                                       SET ARR(IBDX)=""

                                       IF '$DATA(IBDXA(IBDX))

                                           SET IBCNT1=IBCNT1+1

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +6        SET ARRAY=IBCNT_"^"_IBCNT1

 +7        QUIT 

 +8       ;

DISPOE(OEARR,EXARR) ;

 +1        NEW IBCNT,IBDX,IBX

           WRITE @IOF,!,"============================= DIAGNOSIS SCREEN ==============================",!

 +2        SET IBCNT=0

           FOR 

               SET IBCNT=$ORDER(OEARR(IBCNT))

               IF 'IBCNT

                   QUIT 

               SET IBDX=$GET(^ICD9(+OEARR(IBCNT),0))

               Begin DoDot:1

 +3                SET IBX=""

                   IF $DATA(EXARR(+OEARR(IBCNT)))

                       SET IBX="*"

 +4                WRITE !,$JUSTIFY(IBCNT,2),")",?11,IBX,?12,$PIECE(IBDX,U,1),?26,$PIECE(IBDX,U,3)

               End DoDot:1

 +5        QUIT