IBCSC5B.m

IBCSC5B	;ALB/ARH - ADD/ENTER PROSTHETIC ITEMS ; 12/28/93

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

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

	;

	;

EN	;add/edit prosthetic items for a bill, IBIFN required

	S IBX=$$BILL(IBIFN) Q:'IBIFN  S DFN=+IBX,IBDT1=$P(IBX,U,2),IBDT2=$P(IBX,U,3)

	D SET(IBIFN,.IBPDA),PIDISP(DFN,IBDT1,IBDT2,.IBPDE,.IBPDA),DISP(.IBPDA)

E1	S IBPIFN=0,IBDT=$$ASKDT(IBDT1,IBDT2) G:'IBDT EXIT

	S IBPD=$O(IBPDA(IBDT,0)) S:'IBPD IBPD=$O(IBPDE(IBDT,0)) S IBPD=$$ASKPD(IBPD) G:'IBPD E1

	S IBPIFN=$G(IBPDA(IBDT,+IBPD)) I 'IBPIFN S IBPIFN=$$ADD(IBDT,IBIFN,+IBPD,+$G(IBPDE(IBDT,+IBPD))) I 'IBPIFN W " ??" G E1

	I '$D(IBPDE(IBDT,+IBPD)) W !,"This prosthetic item does not exist in this patients prosthetics record.",!

	D EDIT(+IBPIFN) D SET(IBIFN,.IBPDA) W ! G E1

	;

EXIT	K IBPIFN,IBX,IBDT1,IBDT2,IBPDA,IBPDE,IBPD,IBDT

	Q

	;

ASKDT(IBDT1,IBDT2,IBDT)	;

	I +$G(IBIFN) S DIR("?")="Enter the date the item was dilivered to the patient",DIR("??")="^D HELP^IBCSC5B("_IBIFN_")"

	S DIR("A")="Select ITEM DELIVERY DATE",DIR(0)="DO^"_IBDT1_":"_IBDT2_":EX" D ^DIR K DIR,DTOUT,DIRUT

	Q $S(Y?7N:Y,1:0)

	;

ASKPD(PD)	;

	N X,Y

	S DIR("A")="Select PROSTHETIC ITEM",DIR(0)="660,4O" S:+$G(PD) DIR("B")=+$G(^RMPR(661,+$G(PD),0)) D ^DIR S:$D(DIRUT)!(Y'>0) Y="" K DIR,DIRUT

	Q Y

	;

ADD(IBDT,IFN,IBPD,PIFN)	;

	N IBX S IBX=0,DIC="^IBA(362.5,",DIC(0)="AQL",X=IBDT K DA,DO D FILE^DICN K DA,DO,X

	I Y>0 S DIE=DIC,(IBX,DA)=+Y,DR=".02////"_IFN_";.03////"_IBPD_";.04////"_PIFN D ^DIE K DIE,DIC,DA,DR W "... ADDED"

	Q IBX

	;

EDIT(PIFN)	;

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

	Q

	;

SET(IFN,PDARR)	;setup array of all prosthetic devices for bill, array name should be passed by reference

	;returns: PDARR(PD DELIV DATE, PD ITEM (661 ptr))=PD IFN (362.5 ptr),  PDARR=BILL IFN ^ PD count

	N CNT,IBX,IBY,PIFN,IBC K PDARR S IBC="AIFN"_$G(IFN)

	S (CNT,IBX)=0 F  S IBX=$O(^IBA(362.5,IBC,IBX)) Q:'IBX  S PIFN=0 F  S PIFN=$O(^IBA(362.5,IBC,IBX,PIFN)) Q:'PIFN  D

	. S IBY=$G(^IBA(362.5,PIFN,0)) Q:IBY=""  S CNT=CNT+1,PDARR(+IBY,$P(IBY,U,3))=PIFN

	S PDARR=$G(IFN)_"^"_CNT

	Q

	;

DISP(PDARR)	;screen display of existing prosthetic devices for a bill,

	;input should be array returned by SET^IBCSC5B: PDARR(PD DT, PD ITEM)=PD IFN (362.5), pass by reference

	N IBX,IBY,IBZ

	W !!,?5,"-----------------  Existing Prosthetic Items for Bill  -----------------",!

	S IBX=0 F  S IBX=$O(PDARR(IBX)) Q:IBX=""  S IBY=0 F  S IBY=$O(PDARR(IBX,IBY)) Q:'IBY  D

	. S IBZ=$$PIN(IBY) W !,$$DATE(IBX),?12,$P(IBZ,U,1),?20,$P(IBZ,U,2)

	W !

	Q

	;

HELP(IFN)	;called for help from prosthetics enter to display existing devices, displays devices from 660 and 399

	I +$G(IFN) N IBX,IBPDA S IBX=$$BILL(IFN) I +IBX D SET(IFN,.IBPDA),PIDISP($P(IBX,U,1),$P(IBX,U,2),$P(IBX,U,3),"",.IBPDA),DISP(.IBPDA)

	Q

	;

PIDISP(DFN,DT1,DT2,ARRAY,PDARR)	; display all prosthetic items (660) for a patient and date range

	;PDARR (as defined by SET^IBCSC5B) passed by ref. only to check if pros. item is on the bill, not necessary, not changed

	;returns ARRAY(PD DEL DATE (660,10), PD ITEM (660,4=661 ptr))=RECORD (660 ptr), should pass by ref. if desired

	N PIFN,IBX,IBY,PNAME,DDT,PI K ARRAY S DT1=$G(DT1)-.0001,DT2=$G(DT2) S:'DT2 DT2=9999999 Q:'$G(DFN)

	S PIFN=0 F  S PIFN=$O(^RMPR(660,"C",DFN,PIFN)) Q:'PIFN  D

	. S IBX=$G(^RMPR(660,PIFN,0)),DDT=+$P(IBX,U,12)\1 I (DDT<DT1)!(DDT>DT2) Q

	. S ARRAY(DDT,+$P(IBX,U,6))=PIFN

	;

	W @IOF,?33,"PROSTHETICS SCREEN",!,"================================================================================",!

	S DDT=0 F  S DDT=$O(ARRAY(DDT)) Q:'DDT  S PI=0 F  S PI=$O(ARRAY(DDT,PI)) Q:'PI  D

	. S PIFN=ARRAY(DDT,PI),PNAME=$$PIN(PI),IBY=$G(^RMPR(660,PIFN,"AM")),IBX=$G(^RMPR(660,PIFN,0))

	. W !,$S($D(PDARR(+DDT,PI)):"*",1:"")

	. W ?2,$$DATE(DDT),?12,$P(PNAME,U,1),?20,$E($P(PNAME,U,2),1,30),?55,$E($$EXSET^IBEFUNC($P(IBX,U,14),660,12),1,4),?62,$$EXSET^IBEFUNC($P(IBY,U,3),660,62),?70,$J(+$P(IBX,U,16),9,2)

	Q

	;

PIN(PITEM)	;given the pros item IFN (661 ptr) returns name for printing (661,.01^441,.05)

	N IBX,IBY S IBY="" I +$G(PITEM) S IBX=+$G(^RMPR(661,+PITEM,0)) I +IBX S IBY=IBX_U_$$DESCR^PRCPUX1(0,+IBX)

	Q IBY

	;

BILL(IBIFN)	; display all existing prescription refills (52) for a patient and date range

	; (call is a short cut to calling rxdisp if have bill number)

	N IBX,IBY S IBX=$G(^DGCR(399,+$G(IBIFN),0)),IBY=$P(IBX,U,2)

	S IBX=$G(^DGCR(399,+IBIFN,"U")),$P(IBY,U,2)=+IBX,$P(IBY,U,3)=+$P(IBX,U,2)

	Q IBY

	;

DATE(X)	;

	Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)

IBCSC5B   ;ALB/ARH - ADD/ENTER PROSTHETIC ITEMS ; 12/28/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 prosthetic items for a bill, IBIFN required

 +1        SET IBX=$$BILL(IBIFN)

           IF 'IBIFN

               QUIT 

           SET DFN=+IBX

           SET IBDT1=$PIECE(IBX,U,2)

           SET IBDT2=$PIECE(IBX,U,3)

 +2        DO SET(IBIFN,.IBPDA)

           DO PIDISP(DFN,IBDT1,IBDT2,.IBPDE,.IBPDA)

           DO DISP(.IBPDA)

E1         SET IBPIFN=0

           SET IBDT=$$ASKDT(IBDT1,IBDT2)

           IF 'IBDT

               GOTO EXIT

 +1        SET IBPD=$ORDER(IBPDA(IBDT,0))

           IF 'IBPD

               SET IBPD=$ORDER(IBPDE(IBDT,0))

           SET IBPD=$$ASKPD(IBPD)

           IF 'IBPD

               GOTO E1

 +2        SET IBPIFN=$GET(IBPDA(IBDT,+IBPD))

           IF 'IBPIFN

               SET IBPIFN=$$ADD(IBDT,IBIFN,+IBPD,+$GET(IBPDE(IBDT,+IBPD)))

               IF 'IBPIFN

                   WRITE " ??"

                   GOTO E1

 +3        IF '$DATA(IBPDE(IBDT,+IBPD))

               WRITE !,"This prosthetic item does not exist in this patients prosthetics record.",!

 +4        DO EDIT(+IBPIFN)

           DO SET(IBIFN,.IBPDA)

           WRITE !

           GOTO E1

 +5       ;

EXIT       KILL IBPIFN,IBX,IBDT1,IBDT2,IBPDA,IBPDE,IBPD,IBDT

 +1        QUIT 

 +2       ;

ASKDT(IBDT1,IBDT2,IBDT) ;

 +1        IF +$GET(IBIFN)

               SET DIR("?")="Enter the date the item was dilivered to the patient"

               SET DIR("??")="^D HELP^IBCSC5B("_IBIFN_")"

 +2        SET DIR("A")="Select ITEM DELIVERY DATE"

           SET DIR(0)="DO^"_IBDT1_":"_IBDT2_":EX"

           DO ^DIR

           KILL DIR,DTOUT,DIRUT

 +3        QUIT $SELECT(Y?7N:Y,1:0)

 +4       ;

ASKPD(PD) ;

 +1        NEW X,Y

 +2        SET DIR("A")="Select PROSTHETIC ITEM"

           SET DIR(0)="660,4O"

           IF +$GET(PD)

               SET DIR("B")=+$GET(^RMPR(661,+$GET(PD),0))

           DO ^DIR

           IF $DATA(DIRUT)!(Y'>0)

               SET Y=""

           KILL DIR,DIRUT

 +3        QUIT Y

 +4       ;

ADD(IBDT,IFN,IBPD,PIFN) ;

 +1        NEW IBX

           SET IBX=0

           SET DIC="^IBA(362.5,"

           SET DIC(0)="AQL"

           SET X=IBDT

           KILL DA,DO

           DO FILE^DICN

           KILL DA,DO,X

 +2        IF Y>0

               SET DIE=DIC

               SET (IBX,DA)=+Y

               SET DR=".02////"_IFN_";.03////"_IBPD_";.04////"_PIFN

               DO ^DIE

               KILL DIE,DIC,DA,DR

               WRITE "... ADDED"

 +3        QUIT IBX

 +4       ;

EDIT(PIFN) ;

 +1        SET DIDEL=362.5

           SET DIE="^IBA(362.5,"

           SET DR=".01;.03"

           SET DA=PIFN

           DO ^DIE

           KILL DIE,DR,DA,DIC,DIDEL

 +2        QUIT 

 +3       ;

SET(IFN,PDARR) ;setup array of all prosthetic devices for bill, array name should be passed by reference

 +1       ;returns: PDARR(PD DELIV DATE, PD ITEM (661 ptr))=PD IFN (362.5 ptr),  PDARR=BILL IFN ^ PD count

 +2        NEW CNT,IBX,IBY,PIFN,IBC

           KILL PDARR

           SET IBC="AIFN"_$GET(IFN)

 +3        SET (CNT,IBX)=0

           FOR 

               SET IBX=$ORDER(^IBA(362.5,IBC,IBX))

               IF 'IBX

                   QUIT 

               SET PIFN=0

               FOR 

                   SET PIFN=$ORDER(^IBA(362.5,IBC,IBX,PIFN))

                   IF 'PIFN

                       QUIT 

                   Begin DoDot:1

 +4                    SET IBY=$GET(^IBA(362.5,PIFN,0))

                       IF IBY=""

                           QUIT 

                       SET CNT=CNT+1

                       SET PDARR(+IBY,$PIECE(IBY,U,3))=PIFN

                   End DoDot:1

 +5        SET PDARR=$GET(IFN)_"^"_CNT

 +6        QUIT 

 +7       ;

DISP(PDARR) ;screen display of existing prosthetic devices for a bill,

 +1       ;input should be array returned by SET^IBCSC5B: PDARR(PD DT, PD ITEM)=PD IFN (362.5), pass by reference

 +2        NEW IBX,IBY,IBZ

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

 +4        SET IBX=0

           FOR 

               SET IBX=$ORDER(PDARR(IBX))

               IF IBX=""

                   QUIT 

               SET IBY=0

               FOR 

                   SET IBY=$ORDER(PDARR(IBX,IBY))

                   IF 'IBY

                       QUIT 

                   Begin DoDot:1

 +5                    SET IBZ=$$PIN(IBY)

                       WRITE !,$$DATE(IBX),?12,$PIECE(IBZ,U,1),?20,$PIECE(IBZ,U,2)

                   End DoDot:1

 +6        WRITE !

 +7        QUIT 

 +8       ;

HELP(IFN) ;called for help from prosthetics enter to display existing devices, displays devices from 660 and 399

 +1        IF +$GET(IFN)

               NEW IBX,IBPDA

               SET IBX=$$BILL(IFN)

               IF +IBX

                   DO SET(IFN,.IBPDA)

                   DO PIDISP($PIECE(IBX,U,1),$PIECE(IBX,U,2),$PIECE(IBX,U,3),"",.IBPDA)

                   DO DISP(.IBPDA)

 +2        QUIT 

 +3       ;

PIDISP(DFN,DT1,DT2,ARRAY,PDARR) ; display all prosthetic items (660) for a patient and date range

 +1       ;PDARR (as defined by SET^IBCSC5B) passed by ref. only to check if pros. item is on the bill, not necessary, not changed

 +2       ;returns ARRAY(PD DEL DATE (660,10), PD ITEM (660,4=661 ptr))=RECORD (660 ptr), should pass by ref. if desired

 +3        NEW PIFN,IBX,IBY,PNAME,DDT,PI

           KILL ARRAY

           SET DT1=$GET(DT1)-.0001

           SET DT2=$GET(DT2)

           IF 'DT2

               SET DT2=9999999

           IF '$GET(DFN)

               QUIT 

 +4        SET PIFN=0

           FOR 

               SET PIFN=$ORDER(^RMPR(660,"C",DFN,PIFN))

               IF 'PIFN

                   QUIT 

               Begin DoDot:1

 +5                SET IBX=$GET(^RMPR(660,PIFN,0))

                   SET DDT=+$PIECE(IBX,U,12)\1

                   IF (DDT<DT1)!(DDT>DT2)

                       QUIT 

 +6                SET ARRAY(DDT,+$PIECE(IBX,U,6))=PIFN

               End DoDot:1

 +7       ;

 +8        WRITE @IOF,?33,"PROSTHETICS SCREEN",!,"================================================================================",!

 +9        SET DDT=0

           FOR 

               SET DDT=$ORDER(ARRAY(DDT))

               IF 'DDT

                   QUIT 

               SET PI=0

               FOR 

                   SET PI=$ORDER(ARRAY(DDT,PI))

                   IF 'PI

                       QUIT 

                   Begin DoDot:1

 +10                   SET PIFN=ARRAY(DDT,PI)

                       SET PNAME=$$PIN(PI)

                       SET IBY=$GET(^RMPR(660,PIFN,"AM"))

                       SET IBX=$GET(^RMPR(660,PIFN,0))

 +11                   WRITE !,$SELECT($DATA(PDARR(+DDT,PI)):"*",1:"")

 +12                   WRITE ?2,$$DATE(DDT),?12,$PIECE(PNAME,U,1),?20,$EXTRACT($PIECE(PNAME,U,2),1,30),?55,$EXTRACT($$EXSET^IBEFUNC($PIECE(IBX,U,14),660,12),1,4),?62,$$EXSET^IBEFUNC($PIECE(IBY,U,3),660,62),?70,$JUSTIFY(+$PIECE(IBX,U,16),9,2)

                   End DoDot:1

 +13       QUIT 

 +14      ;

PIN(PITEM) ;given the pros item IFN (661 ptr) returns name for printing (661,.01^441,.05)

 +1        NEW IBX,IBY

           SET IBY=""

           IF +$GET(PITEM)

               SET IBX=+$GET(^RMPR(661,+PITEM,0))

               IF +IBX

                   SET IBY=IBX_U_$$DESCR^PRCPUX1(0,+IBX)

 +2        QUIT IBY

 +3       ;

BILL(IBIFN) ; display all existing prescription refills (52) for a patient and date range

 +1       ; (call is a short cut to calling rxdisp if have bill number)

 +2        NEW IBX,IBY

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

           SET IBY=$PIECE(IBX,U,2)

 +3        SET IBX=$GET(^DGCR(399,+IBIFN,"U"))

           SET $PIECE(IBY,U,2)=+IBX

           SET $PIECE(IBY,U,3)=+$PIECE(IBX,U,2)

 +4        QUIT IBY

 +5       ;

DATE(X)   ;

 +1        QUIT $EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)