Index: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATLM1B.m
===================================================================
--- WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATLM1B.m	(revision 613)
+++ WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATLM1B.m	(revision 623)
@@ -1,181 +1,181 @@
-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
+IBATLM1B ;LL/ELZ - TRANSFER PRICING TRANSACTION LIST MENU ; 15-SEP-1998
+ ;;2.0;INTEGRATED BILLING;**115,261**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, 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,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=""
+ . ;
+ . ; 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(IBDATA,"^",6)="":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,$$EX^IBATUTL(660,4,$P(IBDATA,"^",6)),?40,"("
+ . 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,"^",6),$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
