RMPOBIL5 ;(NG)/DUG - HOME OXYGEN BILLING TRANSACTIONS ;7/24/98
;;3.0;PROSTHETICS;**29,99,137**;Feb 09, 1996;Build 5
N RMPRMERG S RMPRMERG=0
S (RC,RA,AN,ANS,RK,RZ)=0 D HDR
F S RA=$O(^RMPR(660,"AC",RMPRDFN,RA)) Q:RA="" D
. S AN=""
. F S AN=$O(^RMPR(660,"AC",RMPRDFN,RA,AN)) Q:AN="" D
. . I $D(^RMPO(665.72,"AC",AN))>0 S RC=RC+1,IT(RC)=AN
;Check for merged accounts
I $D(^XDRM("B",RMPRDFN_";DPT(")) D
. S RMPRMERG=$O(^XDRM("B",RMPRDFN_";DPT(",RMPRMERG)) Q:RMPRMERG=""
. S RMPRMERG=+^XDRM(RMPRMERG,0) Q:RMPRMERG=0 D
.. S RA=0
.. F S RA=$O(^RMPR(660,"AC",RMPRMERG,RA)) Q:RA="" D
... S AN=""
... F S AN=$O(^RMPR(660,"AC",RMPRMERG,RA,AN)) Q:AN="" D
.... I $D(^RMPO(665.72,"AC",AN))>0 S RC=RC+1,IT(RC)=AN
G:'$D(IT) END
DIS ;DISPLAY APPLIANCES OR REPAIRS
I $G(RK)="" S (RC,RK)=""
I RK+1'>RC S RK=RK+1,AN=+IT(RK) D G:$$XIT EXIT G DIS
. S Y=^RMPR(660,AN,0) D PRT,OVER:((IOSL-4)<$Y)
END I RC=0 W !,"No home oxygen items for this veteran!",!! H 3 G EXIT
E D G EXIT
.I RC>0 D I $G(RK)+1'>$G(RC) D DIS
. . W !!,"End of Home Oxygen records for this veteran!" D OVER
.I $G(RC)="" Q
EXIT Q:'$D(RMPRDFN)
W ! K I,J,L,R0,IT,RA
I $D(DUOUT)!($D(DTOUT)) G ASK1^RMPRPAT
S FL=4 G ASK2^RMPRPAT
K RMPRCNUM,TRANS,TRANS1,TYPE,VEN
K AMIS,AN,CST,DATE,DEL,DUOUT,DTOUT,FL,FRM,PAGE,QTY,RC,REM,RZ,RK,SN,STA
Q
XIT() Q '$D(ANS)!(ANS=U)!($D(DUOUT))!($D(DTOUT))
PRT S DATE=$P(Y,U,3),TYPE=$P(Y,U,6),QTY=$P(Y,U,7)
S VEN=$P(Y,U,9),TRANS=$P(Y,U,4),STA=$P(Y,U,10),SN=$P(Y,U,11)
S DEL=$P(Y,U,12)
S CST=$S($P(Y,U,16)'="":$P(Y,U,16),$D(^RMPR(660,AN,"LB")):$P(^RMPR(660,AN,"LB"),U,9),1:"")
;form requested on
S FRM=$P(Y,U,13),REM=$P(Y,U,18)
S DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3)
;S TYPE=$S(TYPE="":"",$D(^RMPR(661,TYPE,0)):$P(^(0),U,1),1:"")
S TYPE=$P($G(^RMPR(660,AN,1)),U,4)
S AMIS=$P(Y,U,15),VEN=$S(VEN="":"",$D(^PRC(440,VEN,0)):$P(^(0),U,1),1:"")
I $D(^RMPR(660.1,"AC",AN)),$P(^RMPR(660.1,$O(^RMPR(660.1,"AC",AN,0)),0),U,11)]"" S AMIS=AMIS_"+"
S TRANS=$S(TRANS]"":TRANS,1:""),TRANS1=""
S:TRANS="X" TRANS1=TRANS,TRANS=""
S DEL=$E(DEL,4,5)_"/"_$E(DEL,6,7)_"/"_$E(DEL,2,3) S:DEL="//" DEL=""
W !,RK,". ",DATE,?13,QTY,?17
;W AMIS_$S(TYPE'="":$E($P(^PRC(441,TYPE,0),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"")
W AMIS_$S(TYPE'="":$E($P($G(^RMPR(661.1,TYPE,0)),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"")
;W:$D(^RMPR(660,$P(IT(RK),U,1),"HST")) $E($P(^("HST"),U,1),1,10)
I TYPE=""&($D(^RMPR(660,$P(IT(RK),U,1),"HST"))) W $E($P(^("HST"),U,1),1,10)
W ?30,TRANS,?31,TRANS1
;display source of procurement for 2529-3 under vendor header
I $D(RMPRLPRO) W ?33,RMPRLPRO
K RMPRLPRO
I VEN'="" W ?33,$E(VEN,1,10)
W:$D(^RMPR(660,$P(IT(RK),U,1),"HST")) $E($P(^("HST"),U,3),1,10)
W:STA'="" ?45,$P(^DIC(4,STA,99),U,1)
W ?50,$E(SN,1,9),?60,DEL
W ?71,$J($FN($S(CST'="":CST,$P(Y,U,17):$P(Y,U,17),1:""),"T",2),9)
W:REM]"" !,?3,REM
I $P(IT(RK),U,2)="" S IT(RK)=IT(RK)_"^"_RZ
Q
OVER N ANS
S RZ=RK W !,"+=Turned-In *=Historical Data I=Initial X=Repair S=Spare R=Replacement",!,"Enter 1-",RK," to show full entry, '^' to exit or `return` to continue. " R ANS:DTIME S:'$T ANS="^"
I ANS="^^" S ANS="^" G ASK1^RMPRPAT Q
I ANS="^" G ASK1^RMPRPAT Q
I ANS="",RK+1'>RC D HDR Q
I ANS="" Q
I ANS'?1N.N!(ANS>RK)!(+ANS=0)!(+ANS'=ANS) W $C(7),!," Must be between 1 and ",RK," to be valid" G OVER
I ANS>0,(ANS<(RK+1)) S AN=ANS,RZ=RK D ^RMPRPAT3
S RK=$P(IT(ANS),U,2)
Q
HDR ;Print Header, Screen 4
W @IOF
S PAGE=3
W !,$E(RMPRNAM,1,20),?23,"SSN: "
W $E(RMPRSSN,1,3)_"-"_$E(RMPRSSN,4,5)_"-"_$E(RMPRSSN,6,10)
W ?42,"DOB: "
S Y=RMPRDOB X ^DD("DD") W Y K Y
W ?61,"CLAIM# ",$G(RMPRCNUM)
W !?4,"Date",?12,"Qty",?19,"HCPCS",?28,"Type",?34,"Vendor",?45,"Sta",?50,"Serial",?58,"Delivery Date",?72,"Tot Cost"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPOBIL5 3897 printed Apr 09, 2024@21:39:40 Page 2
RMPOBIL5 ;(NG)/DUG - HOME OXYGEN BILLING TRANSACTIONS ;7/24/98
+1 ;;3.0;PROSTHETICS;**29,99,137**;Feb 09, 1996;Build 5
+2 NEW RMPRMERG
SET RMPRMERG=0
+3 SET (RC,RA,AN,ANS,RK,RZ)=0
DO HDR
+4 FOR
SET RA=$ORDER(^RMPR(660,"AC",RMPRDFN,RA))
if RA=""
QUIT
Begin DoDot:1
+5 SET AN=""
+6 FOR
SET AN=$ORDER(^RMPR(660,"AC",RMPRDFN,RA,AN))
if AN=""
QUIT
Begin DoDot:2
+7 IF $DATA(^RMPO(665.72,"AC",AN))>0
SET RC=RC+1
SET IT(RC)=AN
End DoDot:2
End DoDot:1
+8 ;Check for merged accounts
+9 IF $DATA(^XDRM("B",RMPRDFN_";DPT("))
Begin DoDot:1
+10 SET RMPRMERG=$ORDER(^XDRM("B",RMPRDFN_";DPT(",RMPRMERG))
if RMPRMERG=""
QUIT
+11 SET RMPRMERG=+^XDRM(RMPRMERG,0)
if RMPRMERG=0
QUIT
Begin DoDot:2
+12 SET RA=0
+13 FOR
SET RA=$ORDER(^RMPR(660,"AC",RMPRMERG,RA))
if RA=""
QUIT
Begin DoDot:3
+14 SET AN=""
+15 FOR
SET AN=$ORDER(^RMPR(660,"AC",RMPRMERG,RA,AN))
if AN=""
QUIT
Begin DoDot:4
+16 IF $DATA(^RMPO(665.72,"AC",AN))>0
SET RC=RC+1
SET IT(RC)=AN
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+17 if '$DATA(IT)
GOTO END
DIS ;DISPLAY APPLIANCES OR REPAIRS
+1 IF $GET(RK)=""
SET (RC,RK)=""
+2 IF RK+1'>RC
SET RK=RK+1
SET AN=+IT(RK)
Begin DoDot:1
+3 SET Y=^RMPR(660,AN,0)
DO PRT
if ((IOSL-4)<$Y)
DO OVER
End DoDot:1
if $$XIT
GOTO EXIT
GOTO DIS
END IF RC=0
WRITE !,"No home oxygen items for this veteran!",!!
HANG 3
GOTO EXIT
+1 IF '$TEST
Begin DoDot:1
+2 IF RC>0
Begin DoDot:2
+3 WRITE !!,"End of Home Oxygen records for this veteran!"
DO OVER
End DoDot:2
IF $GET(RK)+1'>$GET(RC)
DO DIS
+4 IF $GET(RC)=""
QUIT
End DoDot:1
GOTO EXIT
EXIT if '$DATA(RMPRDFN)
QUIT
+1 WRITE !
KILL I,J,L,R0,IT,RA
+2 IF $DATA(DUOUT)!($DATA(DTOUT))
GOTO ASK1^RMPRPAT
+3 SET FL=4
GOTO ASK2^RMPRPAT
+4 KILL RMPRCNUM,TRANS,TRANS1,TYPE,VEN
+5 KILL AMIS,AN,CST,DATE,DEL,DUOUT,DTOUT,FL,FRM,PAGE,QTY,RC,REM,RZ,RK,SN,STA
+6 QUIT
XIT() QUIT '$DATA(ANS)!(ANS=U)!($DATA(DUOUT))!($DATA(DTOUT))
PRT SET DATE=$PIECE(Y,U,3)
SET TYPE=$PIECE(Y,U,6)
SET QTY=$PIECE(Y,U,7)
+1 SET VEN=$PIECE(Y,U,9)
SET TRANS=$PIECE(Y,U,4)
SET STA=$PIECE(Y,U,10)
SET SN=$PIECE(Y,U,11)
+2 SET DEL=$PIECE(Y,U,12)
+3 SET CST=$SELECT($PIECE(Y,U,16)'="":$PIECE(Y,U,16),$DATA(^RMPR(660,AN,"LB")):$PIECE(^RMPR(660,AN,"LB"),U,9),1:"")
+4 ;form requested on
+5 SET FRM=$PIECE(Y,U,13)
SET REM=$PIECE(Y,U,18)
+6 SET DATE=$EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,6,7)_"/"_$EXTRACT(DATE,2,3)
+7 ;S TYPE=$S(TYPE="":"",$D(^RMPR(661,TYPE,0)):$P(^(0),U,1),1:"")
+8 SET TYPE=$PIECE($GET(^RMPR(660,AN,1)),U,4)
+9 SET AMIS=$PIECE(Y,U,15)
SET VEN=$SELECT(VEN="":"",$DATA(^PRC(440,VEN,0)):$PIECE(^(0),U,1),1:"")
+10 IF $DATA(^RMPR(660.1,"AC",AN))
IF $PIECE(^RMPR(660.1,$ORDER(^RMPR(660.1,"AC",AN,0)),0),U,11)]""
SET AMIS=AMIS_"+"
+11 SET TRANS=$SELECT(TRANS]"":TRANS,1:"")
SET TRANS1=""
+12 if TRANS="X"
SET TRANS1=TRANS
SET TRANS=""
+13 SET DEL=$EXTRACT(DEL,4,5)_"/"_$EXTRACT(DEL,6,7)_"/"_$EXTRACT(DEL,2,3)
if DEL="//"
SET DEL=""
+14 WRITE !,RK,". ",DATE,?13,QTY,?17
+15 ;W AMIS_$S(TYPE'="":$E($P(^PRC(441,TYPE,0),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"")
+16 WRITE AMIS_$SELECT(TYPE'="":$EXTRACT($PIECE($GET(^RMPR(661.1,TYPE,0)),U,2),1,10),$PIECE(Y,U,26)="D":"DELIVERY",$PIECE(Y,U,26)="P":"PICKUP",$PIECE(Y,U,17):"SHIPPING",1:"")
+17 ;W:$D(^RMPR(660,$P(IT(RK),U,1),"HST")) $E($P(^("HST"),U,1),1,10)
+18 IF TYPE=""&($DATA(^RMPR(660,$PIECE(IT(RK),U,1),"HST")))
WRITE $EXTRACT($PIECE(^("HST"),U,1),1,10)
+19 WRITE ?30,TRANS,?31,TRANS1
+20 ;display source of procurement for 2529-3 under vendor header
+21 IF $DATA(RMPRLPRO)
WRITE ?33,RMPRLPRO
+22 KILL RMPRLPRO
+23 IF VEN'=""
WRITE ?33,$EXTRACT(VEN,1,10)
+24 if $DATA(^RMPR(660,$PIECE(IT(RK),U,1),"HST"))
WRITE $EXTRACT($PIECE(^("HST"),U,3),1,10)
+25 if STA'=""
WRITE ?45,$PIECE(^DIC(4,STA,99),U,1)
+26 WRITE ?50,$EXTRACT(SN,1,9),?60,DEL
+27 WRITE ?71,$JUSTIFY($FNUMBER($SELECT(CST'="":CST,$PIECE(Y,U,17):$PIECE(Y,U,17),1:""),"T",2),9)
+28 if REM]""
WRITE !,?3,REM
+29 IF $PIECE(IT(RK),U,2)=""
SET IT(RK)=IT(RK)_"^"_RZ
+30 QUIT
OVER NEW ANS
+1 SET RZ=RK
WRITE !,"+=Turned-In *=Historical Data I=Initial X=Repair S=Spare R=Replacement",!,"Enter 1-",RK," to show full entry, '^' to exit or `return` to continue. "
READ ANS:DTIME
if '$TEST
SET ANS="^"
+2 IF ANS="^^"
SET ANS="^"
GOTO ASK1^RMPRPAT
QUIT
+3 IF ANS="^"
GOTO ASK1^RMPRPAT
QUIT
+4 IF ANS=""
IF RK+1'>RC
DO HDR
QUIT
+5 IF ANS=""
QUIT
+6 IF ANS'?1N.N!(ANS>RK)!(+ANS=0)!(+ANS'=ANS)
WRITE $CHAR(7),!," Must be between 1 and ",RK," to be valid"
GOTO OVER
+7 IF ANS>0
IF (ANS<(RK+1))
SET AN=ANS
SET RZ=RK
DO ^RMPRPAT3
+8 SET RK=$PIECE(IT(ANS),U,2)
+9 QUIT
HDR ;Print Header, Screen 4
+1 WRITE @IOF
+2 SET PAGE=3
+3 WRITE !,$EXTRACT(RMPRNAM,1,20),?23,"SSN: "
+4 WRITE $EXTRACT(RMPRSSN,1,3)_"-"_$EXTRACT(RMPRSSN,4,5)_"-"_$EXTRACT(RMPRSSN,6,10)
+5 WRITE ?42,"DOB: "
+6 SET Y=RMPRDOB
XECUTE ^DD("DD")
WRITE Y
KILL Y
+7 WRITE ?61,"CLAIM# ",$GET(RMPRCNUM)
+8 WRITE !?4,"Date",?12,"Qty",?19,"HCPCS",?28,"Type",?34,"Vendor",?45,"Sta",?50,"Serial",?58,"Delivery Date",?72,"Tot Cost"
+9 QUIT
