- 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 Feb 18, 2025@23:34:17 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