IBATLM1B ;LL/ELZ - TRANSFER PRICING TRANSACTION LIST MENU ; 15-SEP-1998
;;2.0;INTEGRATED BILLING;**115,261,389**;21-MAR-94;Build 6
;;Per VHA Directive 2004-038, this routine should not be modified.
;
CF ; -- change facility from patient level
D LMOPT^IBATUTL,CFP^IBATLM0A(DFN),HDR^IBATLM1
Q
CS ; -- change status of patient from patient level
D LMOPT^IBATUTL,CSP^IBATLM0A(DFN),HDR^IBATLM1
Q
CT ; -- cancel a transaction
N IBVAL,DIE,DA,DR,DTOUT,%
D LMOPT^IBATUTL,EN^VALM2($G(XQORNOD(0)))
S (DA,IBVAL)=0,IBVAL=$O(VALMY(IBVAL)) Q:'IBVAL
S DA=$O(@VALMAR@("INDEX",IBVAL,DA))
I $P(^IBAT(351.61,DA,0),U,5)="X" W !!,"Transaction already cancelled!" D H Q
W !!,"Are you sure you want to cancel this transaction"
S %=2 D YN^DICN Q:%'=1
D CANC^IBATFILE(DA),ARRAY^IBATLM1A(VALMAR)
Q
CD ; -- change the current date range for transactions displayed
N IBSAVE S IBSAVE=IBBDT_"^"_IBEDT
D LMOPT^IBATUTL
I $$SLDR^IBATUTL S IBBDT=$P(IBSAVE,"^"),IBEDT=$P(IBSAVE,"^",2)
D ARRAY^IBATLM1A(VALMAR),HDR^IBATLM1
Q
CP ; -- change the currently selected patient
N IBDFN
D LMOPT^IBATUTL
S IBDFN=$$SLPT^IBATUTL I 'IBDFN Q
I $$SLDR^IBATUTL Q
S DFN=IBDFN K ^TMP("VALM DATA",$J),^TMP("VALMAR",$J)
D HDR^IBATLM1,ARRAY^IBATLM1A(VALMAR)
Q
AT ; -- add a transaction
N X,Y,DTOUT,DUOUT,DIRUT,DIROUT
D LMOPT^IBATUTL
S DIR(0)="SMBA^I:Inpatient;O:Outpatient;P:Prescription;R:Prosthetic"
S DIR("A")="Select type of Transaction to add: " D ^DIR Q:$D(DIRUT)
D @Y K ^TMP("VALM DATA",$J),^TMP("VALMAR",$J)
D HDR^IBATLM1,ARRAY^IBATLM1A(VALMAR)
Q
I ; -- select an inpatient stay and add
N IBXA,IBADM,DIRUT,IBIEN,VAIP,IBCHARGE,IBPPF,IBRES
S IBXA=7,IBADM=+$$ADSEL^IBECEA31(DFN) Q:IBADM<0
I IBADM=0 W !!,"Patient has no admissions on file." D H Q
D DUP(IBADM_";DGPM(",.DIRUT)
I $D(DIRUT) D H Q
S VAIP("E")=IBADM D IN5^VADPT S IBPPF=$$PPF^IBATUTL(DFN)
S IBIEN=$$ADM^IBATFILE(DFN,+VAIP(13,1),IBPPF,(+IBADM)_";DGPM(")
I 'IBIEN D M(,$P(IBIEN,"^",2)) Q
I '$G(VAIP(17)) D M(IBIEN,"missing discharge information") Q
S IBRES=$$DIS^IBATFILE(IBIEN,+VAIP(17,1),VAIP(12),VAIP(17))
I 'IBRES D M(IBIEN,$P(IBRES,"^",2)) Q
S IBFINDRT=$$FINDRT^IBATEI(VAIP(12),VAIP(13),DFN)
I '+IBFINDRT D M(IBIEN,"Cannot price transaction") Q
I $P(IBFINDRT,"^",3)="B" S IBRES=$$INPT^IBATFILE(IBIEN,0,0,$P(IBFINDRT,"^",4),0,$P(IBFINDRT,"^",4),$P(IBFINDRT,"^",7))
E S IBRES=$$INPT^IBATFILE(IBIEN,$P(IBFINDRT,"^",3),$P(IBFINDRT,"^",2),$P(IBFINDRT,"^",4),$P(IBFINDRT,"^",5),$P(IBFINDRT,"^",6),$P(IBFINDRT,"^",7))
I 'IBRES D M(IBIEN,"Error in filling pricing information") Q
D M(IBIEN)
Q
M(X,Y) ; Prints message and hangs
N IBSITE S IBSITE=$$SITE^IBATUTL
I $D(X) W !,"Transaction #",IBSITE,X," Added"
I $D(Y) W !,"Cannot complete, ",Y
D H
Q
O ; -- select an outpatient stay
N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT,IBDATA,IBX,IBC,CPTLIST,IBIEN,IBFAC
K ^TMP("IBAT",$J)
S DIR(0)="D^::AEPX",DIR("A")="Visit Date" D ^DIR Q:$D(DIRUT)
S IBDATA("DFN")=DFN,IBDATA("BDT")=Y,IBDATA("EDT")=Y+.99999
;
; scan for the appointments and set up tmp global
; screen to eliminate children and inpatient appointments
D SCAN^IBSDU("PATIENT/DATE",.IBDATA,"I '$P(Y0,""^"",6),$P(Y0,""^"",12)'=8","S ^TMP(""IBAT"",$J,Y)=Y0","")
;
I '$D(^TMP("IBAT",$J)) W !!,"No appointments exist for the date!" D H Q
W !,?10,"Choose which Visit:" S IBX=0
F IBC=1:1 S IBX=$O(^TMP("IBAT",$J,IBX)) Q:IBX<1 S IBDATA=^(IBX) D
. W !,?4,IBC,?10,$$FMTE^XLFDT($P(IBDATA,"^"),"1P")
. W ?35,$$EX^IBATUTL(409.68,.04,$P(IBDATA,"^",4))
. W ?55,$$EX^IBATUTL(409.68,.12,$P(IBDATA,"^",12))
S DIR(0)="N^1:"_(IBC-1),DIR("A")="Select" D ^DIR Q:$D(DIRUT)
S IBX=0 F IBC=1:1:Y S IBX=$O(^TMP("IBAT",$J,IBX))
; check for duplicates
D DUP(IBX_";SCE(",.DIRUT) I $D(DIRUT) D H Q
; setup visit info
S IBX(0)=^TMP("IBAT",$J,IBX)
D GETCPT^SDOE(IBX,"CPTLIST") ;GETDX^SDOE(IBX,"DXLIST")
S IBFAC=$$PPF^IBATUTL(DFN)
; ok now lets format cpts and price
S IBIEN=0 F S IBIEN=$O(CPTLIST(IBIEN)) Q:IBIEN<1 D
. N IBCPT,IBQTY,IBPRICE
. S IBCPT=$P(CPTLIST(IBIEN),"^"),IBQTY=$P(CPTLIST(IBIEN),"^",16)
. S IBPRICE=$$OPT^IBATCM(IBCPT,$P(IBX(0),"^"),IBFAC)
. S IBIEN(IBCPT)=IBQTY_"^"_$S(IBPRICE:$P(IBPRICE,"^",4),1:0)
S IBIEN=$$OUT^IBATFILE(DFN,$P(IBX(0),"^"),IBFAC,IBX_";SCE(",.IBIEN)
W !!,"Transaction Number ",$P(^IBAT(351.61,IBIEN,0),"^")," Added!" D H
K ^TMP("IBAT",$J)
Q
P ; -- select an rx
N IBRX,IBPSRX,IBOUT,IBCOUNT,DIRUT,DIR,IBP,IBNUM,IBSITE,IBQUIT,IBBDT,IBEDT
S (IBCOUNT,IBOUT)=0
Q:$$SLDR^IBATUTL
D RX^IBATRX(DFN,IBBDT,IBEDT,.IBRX)
I '$D(IBRX) W !!,"No Rx's on file for date range selected." D H Q
W @IOF,!,"Prescriptions Issued:",!
S IBPSRX=0 F S IBPSRX=$O(IBRX(IBPSRX)) Q:IBPSRX=""!(IBOUT) D
. S IBDT=0 F S IBDT=$O(IBRX(IBPSRX,IBDT)) Q:IBDT<1!(IBOUT) D
.. S IBDAT=IBRX(IBPSRX,IBDT),IBCOUNT=IBCOUNT+1
.. W !,IBCOUNT,?4,$$FMTE^XLFDT(IBDT,"5D"),?18,$P(IBDAT,"^")
.. W "(",$P(IBDAT,"^",2),")",?35,$E($P(IBDAT,"^",4),1,27)
.. W ?65,$J($FN($P(IBDAT,"^",5)*$P(IBDAT,"^",6),",",2),12)
.. ;I $Y+4>IOSL D H X:'$D(DIRUT) "W @IOF,!" I $D(DIRUT) S IBOUT=1 Q
.. S IBNUM(IBCOUNT)=IBPSRX_"^"_IBDT
W ! K DIRUT S DIR(0)="L^1:"_IBCOUNT,DIR("A")="Which Prescriptions"
D ^DIR Q:$D(DIRUT) W !!,"Selected number(s): "_Y S IBNUM=Y
W !,"Ok to add: " S %=1 D YN^DICN I %'=1 D H Q
S IBFAC=$$PPF^IBATUTL(DFN),IBSITE=$$SITE^IBATUTL
F IBP=1:1 S IBRX=$P(IBNUM,",",IBP) Q:'IBRX D
. S IBRX(0)=IBRX($P(IBNUM(IBRX),"^"),$P(IBNUM(IBRX),"^",2))
. D DUP($P(IBRX(0),"^")_";PSRX(;"_$P(IBRX(0),"^",2),.IBQUIT)
. I $G(IBQUIT) K IBQUIT Q
. W !!,"Adding Transaction number ",IBSITE
. W $$RX^IBATFILE(DFN,$P(IBNUM(IBRX),"^",2),IBFAC,$P(IBRX(0),"^")_";PSRX(;"_$P(IBRX(0),"^",2),$P(IBRX(0),"^",3),$P(IBRX(0),"^",5),$P(IBRX(0),"^",6))
. W "!" H 1
D H
Q
R ; -- select an prosthetic
N IBBDT,IBEDT,IBCOUNT,IBOUT,IBDA,IBDATA,IBDATA1,IBP,IBC,IBCOUNT,%,DIRUT
;
S (IBCOUNT,IBOUT)=0
Q:$$SLDR^IBATUTL
;
; look up prosthetic devices issued
S IBDA="" F S IBDA=$O(^RMPR(660,"C",DFN,IBDA)) Q:'IBDA D
. ;
. ; valid data
. S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA="" S IBDATA1=$G(^RMPR(660,+IBDA,1))
. ;
. ; valid date range
. I $P(IBDATA,"^",12)<IBBDT!($P(IBDATA,"^",12)>IBEDT) Q
. ;
. ; checks from RMPRBIL copied 4/7/2000 with mod for AM node patients
. I $S('$D(^RMPR(660,IBDA,"AM")):1,$P(IBDATA,"^",9)="":1,$P(IBDATA,"^",12)="":1,$P(IBDATA1,"^",4)="":1,$P(IBDATA,"^",14)="V":1,$P(IBDATA,"^",15)="*":1,1:0) Q
. ;
. ; set array
. S IBCOUNT=IBCOUNT+1,IBP(IBCOUNT,IBDA)=IBDATA
;
I 'IBCOUNT W !!,"No Prosthetic Devices on file for date range selected." D H Q
;
W @IOF,!,"Prosthetic Devices Issued:",!
F IBC=1:1:IBCOUNT Q:IBOUT D
. S IBDATA=IBP(IBC,$O(IBP(IBC,0)))
. W !,IBC,?4,$$FMTE^XLFDT($P(IBDATA,"^",12),"5D")
. W ?20,$E($P($$PIN^IBATUTL($O(IBP(IBC,0))),U,2),1,28),?50,"("
. W $$EX^IBATUTL(660,62,$P(^RMPR(660,$O(IBP(IBC,0)),"AM"),"^",3)),")"
. W ?65,$J($FN($P(IBDATA,"^",16),",",2),12)
;
W ! K DIRUT S DIR(0)="N^1:"_IBCOUNT_":0"
S DIR("A")="Which Prosthetic Device" D ^DIR Q:$D(DIRUT) S IBC=+Y
W !,"Ok to add: " S %=1 D YN^DICN I %'=1 D H Q
S IBDA=$O(IBP(IBC,0)),IBDATA=IBP(IBC,IBDA)
D DUP(IBDA_";RMPR(660,",.DIRUT)
I $D(DIRUT) D H Q
W !!,"Adding Transaction number ",$$SITE^IBATUTL
W $$RMPR^IBATFILE(DFN,$P(IBDATA,"^",12),$$PPF^IBATUTL(DFN),(IBDA_";RMPR(660,"),,$P(IBDATA,"^",16))
W "!" H 1
D H
Q
H ; -- page reader
N DIR,X,Y,DTOUT,DUOUT,DIROUT
W !! S DIR(0)="E" D ^DIR
Q
DUP(IBSOURCE,IBQUIT) ; -- checks for dups that are not cancelled
N IBT S IBT=0
F S IBT=$O(^IBAT(351.61,"AD",IBSOURCE,IBT)) Q:IBT<1!($D(IBQUIT)) D
. Q:$P(^IBAT(351.61,IBT,0),"^",5)="X"
. W !,$S(IBSOURCE["SCE(":"Visit",IBSOURCE["DGPM(":"Admission",IBSOURCE["RMPR(":"Prosthetic",1:"Prescription")," exists already!" S IBQUIT=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBATLM1B 7837 printed Sep 23, 2025@19:44:06 Page 2
IBATLM1B ;LL/ELZ - TRANSFER PRICING TRANSACTION LIST MENU ; 15-SEP-1998
+1 ;;2.0;INTEGRATED BILLING;**115,261,389**;21-MAR-94;Build 6
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
CF ; -- change facility from patient level
+1 DO LMOPT^IBATUTL
DO CFP^IBATLM0A(DFN)
DO HDR^IBATLM1
+2 QUIT
CS ; -- change status of patient from patient level
+1 DO LMOPT^IBATUTL
DO CSP^IBATLM0A(DFN)
DO HDR^IBATLM1
+2 QUIT
CT ; -- cancel a transaction
+1 NEW IBVAL,DIE,DA,DR,DTOUT,%
+2 DO LMOPT^IBATUTL
DO EN^VALM2($GET(XQORNOD(0)))
+3 SET (DA,IBVAL)=0
SET IBVAL=$ORDER(VALMY(IBVAL))
if 'IBVAL
QUIT
+4 SET DA=$ORDER(@VALMAR@("INDEX",IBVAL,DA))
+5 IF $PIECE(^IBAT(351.61,DA,0),U,5)="X"
WRITE !!,"Transaction already cancelled!"
DO H
QUIT
+6 WRITE !!,"Are you sure you want to cancel this transaction"
+7 SET %=2
DO YN^DICN
if %'=1
QUIT
+8 DO CANC^IBATFILE(DA)
DO ARRAY^IBATLM1A(VALMAR)
+9 QUIT
CD ; -- change the current date range for transactions displayed
+1 NEW IBSAVE
SET IBSAVE=IBBDT_"^"_IBEDT
+2 DO LMOPT^IBATUTL
+3 IF $$SLDR^IBATUTL
SET IBBDT=$PIECE(IBSAVE,"^")
SET IBEDT=$PIECE(IBSAVE,"^",2)
+4 DO ARRAY^IBATLM1A(VALMAR)
DO HDR^IBATLM1
+5 QUIT
CP ; -- change the currently selected patient
+1 NEW IBDFN
+2 DO LMOPT^IBATUTL
+3 SET IBDFN=$$SLPT^IBATUTL
IF 'IBDFN
QUIT
+4 IF $$SLDR^IBATUTL
QUIT
+5 SET DFN=IBDFN
KILL ^TMP("VALM DATA",$JOB),^TMP("VALMAR",$JOB)
+6 DO HDR^IBATLM1
DO ARRAY^IBATLM1A(VALMAR)
+7 QUIT
AT ; -- add a transaction
+1 NEW X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+2 DO LMOPT^IBATUTL
+3 SET DIR(0)="SMBA^I:Inpatient;O:Outpatient;P:Prescription;R:Prosthetic"
+4 SET DIR("A")="Select type of Transaction to add: "
DO ^DIR
if $DATA(DIRUT)
QUIT
+5 DO @Y
KILL ^TMP("VALM DATA",$JOB),^TMP("VALMAR",$JOB)
+6 DO HDR^IBATLM1
DO ARRAY^IBATLM1A(VALMAR)
+7 QUIT
I ; -- select an inpatient stay and add
+1 NEW IBXA,IBADM,DIRUT,IBIEN,VAIP,IBCHARGE,IBPPF,IBRES
+2 SET IBXA=7
SET IBADM=+$$ADSEL^IBECEA31(DFN)
if IBADM<0
QUIT
+3 IF IBADM=0
WRITE !!,"Patient has no admissions on file."
DO H
QUIT
+4 DO DUP(IBADM_";DGPM(",.DIRUT)
+5 IF $DATA(DIRUT)
DO H
QUIT
+6 SET VAIP("E")=IBADM
DO IN5^VADPT
SET IBPPF=$$PPF^IBATUTL(DFN)
+7 SET IBIEN=$$ADM^IBATFILE(DFN,+VAIP(13,1),IBPPF,(+IBADM)_";DGPM(")
+8 IF 'IBIEN
DO M(,$PIECE(IBIEN,"^",2))
QUIT
+9 IF '$GET(VAIP(17))
DO M(IBIEN,"missing discharge information")
QUIT
+10 SET IBRES=$$DIS^IBATFILE(IBIEN,+VAIP(17,1),VAIP(12),VAIP(17))
+11 IF 'IBRES
DO M(IBIEN,$PIECE(IBRES,"^",2))
QUIT
+12 SET IBFINDRT=$$FINDRT^IBATEI(VAIP(12),VAIP(13),DFN)
+13 IF '+IBFINDRT
DO M(IBIEN,"Cannot price transaction")
QUIT
+14 IF $PIECE(IBFINDRT,"^",3)="B"
SET IBRES=$$INPT^IBATFILE(IBIEN,0,0,$PIECE(IBFINDRT,"^",4),0,$PIECE(IBFINDRT,"^",4),$PIECE(IBFINDRT,"^",7))
+15 IF '$TEST
SET IBRES=$$INPT^IBATFILE(IBIEN,$PIECE(IBFINDRT,"^",3),$PIECE(IBFINDRT,"^",2),$PIECE(IBFINDRT,"^",4),$PIECE(IBFINDRT,"^",5),$PIECE(IBFINDRT,"^",6),$PIECE(IBFINDRT,"^",7))
+16 IF 'IBRES
DO M(IBIEN,"Error in filling pricing information")
QUIT
+17 DO M(IBIEN)
+18 QUIT
M(X,Y) ; Prints message and hangs
+1 NEW IBSITE
SET IBSITE=$$SITE^IBATUTL
+2 IF $DATA(X)
WRITE !,"Transaction #",IBSITE,X," Added"
+3 IF $DATA(Y)
WRITE !,"Cannot complete, ",Y
+4 DO H
+5 QUIT
O ; -- select an outpatient stay
+1 NEW X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT,IBDATA,IBX,IBC,CPTLIST,IBIEN,IBFAC
+2 KILL ^TMP("IBAT",$JOB)
+3 SET DIR(0)="D^::AEPX"
SET DIR("A")="Visit Date"
DO ^DIR
if $DATA(DIRUT)
QUIT
+4 SET IBDATA("DFN")=DFN
SET IBDATA("BDT")=Y
SET IBDATA("EDT")=Y+.99999
+5 ;
+6 ; scan for the appointments and set up tmp global
+7 ; screen to eliminate children and inpatient appointments
+8 DO SCAN^IBSDU("PATIENT/DATE",.IBDATA,"I '$P(Y0,""^"",6),$P(Y0,""^"",12)'=8","S ^TMP(""IBAT"",$J,Y)=Y0","")
+9 ;
+10 IF '$DATA(^TMP("IBAT",$JOB))
WRITE !!,"No appointments exist for the date!"
DO H
QUIT
+11 WRITE !,?10,"Choose which Visit:"
SET IBX=0
+12 FOR IBC=1:1
SET IBX=$ORDER(^TMP("IBAT",$JOB,IBX))
if IBX<1
QUIT
SET IBDATA=^(IBX)
Begin DoDot:1
+13 WRITE !,?4,IBC,?10,$$FMTE^XLFDT($PIECE(IBDATA,"^"),"1P")
+14 WRITE ?35,$$EX^IBATUTL(409.68,.04,$PIECE(IBDATA,"^",4))
+15 WRITE ?55,$$EX^IBATUTL(409.68,.12,$PIECE(IBDATA,"^",12))
End DoDot:1
+16 SET DIR(0)="N^1:"_(IBC-1)
SET DIR("A")="Select"
DO ^DIR
if $DATA(DIRUT)
QUIT
+17 SET IBX=0
FOR IBC=1:1:Y
SET IBX=$ORDER(^TMP("IBAT",$JOB,IBX))
+18 ; check for duplicates
+19 DO DUP(IBX_";SCE(",.DIRUT)
IF $DATA(DIRUT)
DO H
QUIT
+20 ; setup visit info
+21 SET IBX(0)=^TMP("IBAT",$JOB,IBX)
+22 ;GETDX^SDOE(IBX,"DXLIST")
DO GETCPT^SDOE(IBX,"CPTLIST")
+23 SET IBFAC=$$PPF^IBATUTL(DFN)
+24 ; ok now lets format cpts and price
+25 SET IBIEN=0
FOR
SET IBIEN=$ORDER(CPTLIST(IBIEN))
if IBIEN<1
QUIT
Begin DoDot:1
+26 NEW IBCPT,IBQTY,IBPRICE
+27 SET IBCPT=$PIECE(CPTLIST(IBIEN),"^")
SET IBQTY=$PIECE(CPTLIST(IBIEN),"^",16)
+28 SET IBPRICE=$$OPT^IBATCM(IBCPT,$PIECE(IBX(0),"^"),IBFAC)
+29 SET IBIEN(IBCPT)=IBQTY_"^"_$SELECT(IBPRICE:$PIECE(IBPRICE,"^",4),1:0)
End DoDot:1
+30 SET IBIEN=$$OUT^IBATFILE(DFN,$PIECE(IBX(0),"^"),IBFAC,IBX_";SCE(",.IBIEN)
+31 WRITE !!,"Transaction Number ",$PIECE(^IBAT(351.61,IBIEN,0),"^")," Added!"
DO H
+32 KILL ^TMP("IBAT",$JOB)
+33 QUIT
P ; -- select an rx
+1 NEW IBRX,IBPSRX,IBOUT,IBCOUNT,DIRUT,DIR,IBP,IBNUM,IBSITE,IBQUIT,IBBDT,IBEDT
+2 SET (IBCOUNT,IBOUT)=0
+3 if $$SLDR^IBATUTL
QUIT
+4 DO RX^IBATRX(DFN,IBBDT,IBEDT,.IBRX)
+5 IF '$DATA(IBRX)
WRITE !!,"No Rx's on file for date range selected."
DO H
QUIT
+6 WRITE @IOF,!,"Prescriptions Issued:",!
+7 SET IBPSRX=0
FOR
SET IBPSRX=$ORDER(IBRX(IBPSRX))
if IBPSRX=""!(IBOUT)
QUIT
Begin DoDot:1
+8 SET IBDT=0
FOR
SET IBDT=$ORDER(IBRX(IBPSRX,IBDT))
if IBDT<1!(IBOUT)
QUIT
Begin DoDot:2
+9 SET IBDAT=IBRX(IBPSRX,IBDT)
SET IBCOUNT=IBCOUNT+1
+10 WRITE !,IBCOUNT,?4,$$FMTE^XLFDT(IBDT,"5D"),?18,$PIECE(IBDAT,"^")
+11 WRITE "(",$PIECE(IBDAT,"^",2),")",?35,$EXTRACT($PIECE(IBDAT,"^",4),1,27)
+12 WRITE ?65,$JUSTIFY($FNUMBER($PIECE(IBDAT,"^",5)*$PIECE(IBDAT,"^",6),",",2),12)
+13 ;I $Y+4>IOSL D H X:'$D(DIRUT) "W @IOF,!" I $D(DIRUT) S IBOUT=1 Q
+14 SET IBNUM(IBCOUNT)=IBPSRX_"^"_IBDT
End DoDot:2
End DoDot:1
+15 WRITE !
KILL DIRUT
SET DIR(0)="L^1:"_IBCOUNT
SET DIR("A")="Which Prescriptions"
+16 DO ^DIR
if $DATA(DIRUT)
QUIT
WRITE !!,"Selected number(s): "_Y
SET IBNUM=Y
+17 WRITE !,"Ok to add: "
SET %=1
DO YN^DICN
IF %'=1
DO H
QUIT
+18 SET IBFAC=$$PPF^IBATUTL(DFN)
SET IBSITE=$$SITE^IBATUTL
+19 FOR IBP=1:1
SET IBRX=$PIECE(IBNUM,",",IBP)
if 'IBRX
QUIT
Begin DoDot:1
+20 SET IBRX(0)=IBRX($PIECE(IBNUM(IBRX),"^"),$PIECE(IBNUM(IBRX),"^",2))
+21 DO DUP($PIECE(IBRX(0),"^")_";PSRX(;"_$PIECE(IBRX(0),"^",2),.IBQUIT)
+22 IF $GET(IBQUIT)
KILL IBQUIT
QUIT
+23 WRITE !!,"Adding Transaction number ",IBSITE
+24 WRITE $$RX^IBATFILE(DFN,$PIECE(IBNUM(IBRX),"^",2),IBFAC,$PIECE(IBRX(0),"^")_";PSRX(;"_$PIECE(IBRX(0),"^",2),$PIECE(IBRX(0),"^",3),$PIECE(IBRX(0),"^",5),$PIECE(IBRX(0),"^",6))
+25 WRITE "!"
HANG 1
End DoDot:1
+26 DO H
+27 QUIT
R ; -- select an prosthetic
+1 NEW IBBDT,IBEDT,IBCOUNT,IBOUT,IBDA,IBDATA,IBDATA1,IBP,IBC,IBCOUNT,%,DIRUT
+2 ;
+3 SET (IBCOUNT,IBOUT)=0
+4 if $$SLDR^IBATUTL
QUIT
+5 ;
+6 ; look up prosthetic devices issued
+7 SET IBDA=""
FOR
SET IBDA=$ORDER(^RMPR(660,"C",DFN,IBDA))
if 'IBDA
QUIT
Begin DoDot:1
+8 ;
+9 ; valid data
+10 SET IBDATA=$GET(^RMPR(660,+IBDA,0))
if IBDATA=""
QUIT
SET IBDATA1=$GET(^RMPR(660,+IBDA,1))
+11 ;
+12 ; valid date range
+13 IF $PIECE(IBDATA,"^",12)<IBBDT!($PIECE(IBDATA,"^",12)>IBEDT)
QUIT
+14 ;
+15 ; checks from RMPRBIL copied 4/7/2000 with mod for AM node patients
+16 IF $SELECT('$DATA(^RMPR(660,IBDA,"AM")):1,$PIECE(IBDATA,"^",9)="":1,$PIECE(IBDATA,"^",12)="":1,$PIECE(IBDATA1,"^",4)="":1,$PIECE(IBDATA,"^",14)="V":1,$PIECE(IBDATA,"^",15)="*":1,1:0)
QUIT
+17 ;
+18 ; set array
+19 SET IBCOUNT=IBCOUNT+1
SET IBP(IBCOUNT,IBDA)=IBDATA
End DoDot:1
+20 ;
+21 IF 'IBCOUNT
WRITE !!,"No Prosthetic Devices on file for date range selected."
DO H
QUIT
+22 ;
+23 WRITE @IOF,!,"Prosthetic Devices Issued:",!
+24 FOR IBC=1:1:IBCOUNT
if IBOUT
QUIT
Begin DoDot:1
+25 SET IBDATA=IBP(IBC,$ORDER(IBP(IBC,0)))
+26 WRITE !,IBC,?4,$$FMTE^XLFDT($PIECE(IBDATA,"^",12),"5D")
+27 WRITE ?20,$EXTRACT($PIECE($$PIN^IBATUTL($ORDER(IBP(IBC,0))),U,2),1,28),?50,"("
+28 WRITE $$EX^IBATUTL(660,62,$PIECE(^RMPR(660,$ORDER(IBP(IBC,0)),"AM"),"^",3)),")"
+29 WRITE ?65,$JUSTIFY($FNUMBER($PIECE(IBDATA,"^",16),",",2),12)
End DoDot:1
+30 ;
+31 WRITE !
KILL DIRUT
SET DIR(0)="N^1:"_IBCOUNT_":0"
+32 SET DIR("A")="Which Prosthetic Device"
DO ^DIR
if $DATA(DIRUT)
QUIT
SET IBC=+Y
+33 WRITE !,"Ok to add: "
SET %=1
DO YN^DICN
IF %'=1
DO H
QUIT
+34 SET IBDA=$ORDER(IBP(IBC,0))
SET IBDATA=IBP(IBC,IBDA)
+35 DO DUP(IBDA_";RMPR(660,",.DIRUT)
+36 IF $DATA(DIRUT)
DO H
QUIT
+37 WRITE !!,"Adding Transaction number ",$$SITE^IBATUTL
+38 WRITE $$RMPR^IBATFILE(DFN,$PIECE(IBDATA,"^",12),$$PPF^IBATUTL(DFN),(IBDA_";RMPR(660,"),,$PIECE(IBDATA,"^",16))
+39 WRITE "!"
HANG 1
+40 DO H
+41 QUIT
H ; -- page reader
+1 NEW DIR,X,Y,DTOUT,DUOUT,DIROUT
+2 WRITE !!
SET DIR(0)="E"
DO ^DIR
+3 QUIT
DUP(IBSOURCE,IBQUIT) ; -- checks for dups that are not cancelled
+1 NEW IBT
SET IBT=0
+2 FOR
SET IBT=$ORDER(^IBAT(351.61,"AD",IBSOURCE,IBT))
if IBT<1!($DATA(IBQUIT))
QUIT
Begin DoDot:1
+3 if $PIECE(^IBAT(351.61,IBT,0),"^",5)="X"
QUIT
+4 WRITE !,$SELECT(IBSOURCE["SCE(":"Visit",IBSOURCE["DGPM(":"Admission",IBSOURCE["RMPR(":"Prosthetic",1:"Prescription")," exists already!"
SET IBQUIT=1
End DoDot:1
+5 QUIT
