RMPRAINQ ;PHX/JLT/HNB -Print History, Vehicle of Reg. ;1/30/1995
;;3.0;PROSTHETICS;**20,90**;Feb 09, 1996
D GETPAT^RMPRUTIL Q:'$D(RMPRDFN)
S %ZIS="QM" D ^%ZIS G:POP EXIT
I $D(IO("Q")) K IO("Q") D
.S ZTRTN="DU^RMPRAINQ",ZTDESC="PROSTHETICS INQUIRE TO PATIENT VEHICLE OF RECORD",ZTIO=ION
.F RMPRB="RMPRDFN","RMPRNAM","RMPRSSN" S ZTSAVE(RMPRB)=""
.D ^%ZTLOAD
I $D(ZTSK) G EXIT
DU ;PRINT AUTO-ADAPTIVE EQUIPMENT, entry point from ??
N PAGE,RMPRL,RMPRI,RMPRT,RMPRD,RDAT,RMPRB,FL
;K RMPRBACK
S DFN=RMPRDFN D ELIG^VADPT S RMPRCNUM=VAEL(7) K VAEL
S PAGE=0,RMPRI=0,$P(RMPRL,"-",IOM)=""
U IO D HDR
F S RMPRI=$O(^RMPR(667,"C",RMPRDFN,RMPRI)) Q:RMPRI'>0!($D(FL)) D
.S RMPRB=^RMPR(667,RMPRI,0)
.S RMPRT=$O(^RMPR(667,"B",$P(RMPRB,U,1),0)),RMPRD=$P(^RMPR(667,RMPRT,0),U,3)
.;vehicle
.I $D(^RMPR(667.3,"C",RMPRT)) D LP Q
.;vehicle, no transactions
.S RDAT=1 D ONE
W:'$D(RDAT) !!,?15,"NO VEHICLE OF RECORD FOR THIS PATIENT",!
I IOST["C-" I $Y<IOSL-5 F W ! Q:$Y>IOSL-5
I IOST["C-"&('$D(FL)) K DIR S DIR(0)="E" D ^DIR
W @IOF
;
EXIT K DIC,RMPRINFO,RA,RK,RI,FL,DIR,Y,RMPRB D ^%ZISC
I $D(RMPRBACK)!($D(RMPRBAC1)) G ASK1^RMPRPAT
;E K RMPRDFN,RMPRNAM,RMPRSSN,RMPRDOB,RMPRCNUM
Q
LP ;find vehicle entries
D WR W ! N CNT,RPREV S RK=0,CNT=0,RPREV=0
F S RK=$O(^RMPR(667.3,"C",RMPRT,RK)) Q:RK'>0!($D(FL)) D
.S RDAT=1 D WR1
D TOT
Q
HDR S PAGE=PAGE+1
W @IOF,!,"NAME: ",RMPRNAM,?33,"SSN: ",RMPRSSN
W ?50,"CLAIM NO. ",RMPRCNUM
W !,"VEHICLE ID#",?20,"YEAR",?25,"PURCHASE DATE",?40,"MAKE"
W ?51,"MODEL",?70,"PAGE ",PAGE
W !,"PROCESS DATE",?15,"ITEM",?40,"QTY",?51,"COST",?62,"AMIS"
W ?72,"TYPE",!?30,"'*' Denotes Inactive Vehicle of Record",!,RMPRL
Q
WR I IOST["C-"&($Y+6>IOSL) S DIR(0)="E" D ^DIR I 'Y S FL=1 Q
D:$Y+6>IOSL HDR I $D(^RMPR(667,RMPRT,2)),$P(^(2),U)=0 S RMPRB="*"_RMPRB
PG ;display auto, no items
W !,$E($P(RMPRB,U,1),1,19),?20,$P(RMPRB,U,5)
S Y=$P(RMPRB,U,4) D DD^%DT W ?25,Y
W:+$P(RMPRB,U,6) ?40,$E(^RMPR(667.2,$P(RMPRB,U,6),0),1,9)
W ?51,$E($P(RMPRB,U,7),1,9)
I RMPRD S Y=RMPRD D DD^%DT W ?62,"4502: ",Y
W ?62,$S($P(RMPRB,U,9)="A":"ANKYLOSIS",$P(RMPRB,U,9)="V":"VOC REHAB",1:"")
I $D(^RMPR(667,RMPRT,1,0)) S RA=0 F S RA=$O(^RMPR(667,RMPRT,1,RA)) Q:RA'>0 W !,^(RA,0)
Q
WR1 ;items, or transactions
I IOST["C-"&($Y+6>IOSL) S DIR(0)="E" D ^DIR I 'Y S FL=1 Q
I $Y+6>IOSL D HDR,PG W !
S RMPRINFO=^RMPR(667.3,RK,0),$P(RMPRINFO,U,15)=+$P(RMPRINFO,U,4)*+$P(RMPRINFO,U,7)
S:'$P(RMPRINFO,U,15) $P(RMPRINFO,U,15)=$P(RMPRINFO,U,4)
S Y=$P(RMPRINFO,U) D DD^%DT
;print total if process date different
I RPREV'=Y&(RPREV'=0) D TOT
S RPREV=Y
W !,Y
W ?15,$S($D(^RMPR(667.1,+$P(RMPRINFO,U,3),0)):$E(^RMPR(667.1,$P(RMPRINFO,U,3),0),1,20),1:"UNK")
W ?40,$P(RMPRINFO,U,7),?48
W ?48+(10-($L($FN($P(RMPRINFO,U,15),",",2)))),"$",$FN($P(RMPRINFO,U,15),",",2)
S CNT=CNT+$P(RMPRINFO,U,15)
W ?62,$S($P(RMPRINFO,U,5)["R":"REPAIR",$P(RMPRINFO,U,5)["A":"VAN MOD",$P(RMPRINFO,U,5)["B":"ADAP EQP",1:"")
W ?72,$S($P(RMPRINFO,U,8)="I":"INITIAL",$P(RMPRINFO,U,8)="R":"REPLACE",$P(RMPRINFO,U,8)="X":"REPAIR",$P(RMPRINFO,U,8)="S":"SPARE",$P(RMPRINFO,U,8)=5:"RENTAL",1:"")
I $D(^RMPR(667.3,RK,1,0)) D
.S RA=0
.F S RA=$O(^RMPR(667.3,RK,1,RA)) Q:RA'>0 W !,^(RA,0)
Q
TOT Q:$D(FL)
W !!?31,"Total/Date:"
W ?48+(10-$L($FN(CNT,",",2))),"$",$FN(CNT,",",2),!
S CNT=0
Q
ONE ;vehicle, no items.
I IOST["C-"&($Y+6>IOSL) S DIR(0)="E" D ^DIR I 'Y S FL=1 Q
D:$Y+6>IOSL HDR
I $D(^RMPR(667,RMPRT,2)),$P(^(2),U)=0 S RMPRB="*"_RMPRB
W !,$E($P(RMPRB,U,1),1,19),?20,$P(RMPRB,U,5)
S Y=$P(RMPRB,U,4) D DD^%DT W ?25,Y
W:$P(RMPRB,U,6) ?40,$S($D(^RMPR(667.2,+$P(RMPRB,U,6),0)):$E(^RMPR(667.2,$P(RMPRB,U,6),0),1,9),1:"UNK")
W ?51,$E($P(RMPRB,U,7),1,9)
I RMPRD S Y=RMPRD D DD^%DT W ?62,"4502: ",Y
W ?62,$S($P(RMPRB,U,9)="A":"ANKYLOSIS",$P(RMPRB,U,9)="V":"VOC REHAB",1:"")
I $D(^RMPR(667,RMPRT,1,0)) S RA=0 F S RA=$O(^RMPR(667,RMPRT,1,RA)) Q:RA'>0 W !,^(RA,0)
W !?15,"NO ITEMS ON THIS VEHICLE OF RECORD",!,RMPRL ;K DIR S DIR(0)="E" D ^DIR Q:$D(DUOUT)!($D(DTOUT)) W @IOF
Q
VOR ;EDIT/DELETE VEHICLE OF RECORD
K DIC,DIE,DA,DIK,RMPRA,DR D DIV4^RMPRSIT I $D(X) Q
VH S DIC=667,DIC(0)="AEQMNZ"
S DIC("A")="Please Enter Patient Name or Vehicle ID#: "
S DIC("W")="D LK^RMPRAVR"
S DIC("S")="I $P(^(0),U,10)=RMPR(""STA"")"
I RMPRSITE=1 S DIC("S")=DIC("S")_"!($P(^(0),U,10)="""")"
D ^DIC I +Y'>0 K DIC,Y Q
L +^RMPR(667,+Y,0):1
I $T=0 W ?5,$C(7),!,"Someone else is Editing this Entry!" K DIC,Y Q
S (RMPRDA,DA)=+Y,DR=".01;9STATUS;10;2;2.1;3;4;5;6;7;11;2.2;2.3;I $P(^RMPR(667,DA,2),U,3)'=4 S Y="""";2.4"
S DIE=DIC D ^DIE
I '$D(DA) S RI=0 F S RI=$O(^RMPR(667.3,"C",RMPRDA,RI)) Q:RI'>0 S DA=RI,DIK="^RMPR(667.3," D ^DIK
W ! L -^RMPR(667,RMPRDA,0) K DR,DIE G VH
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRAINQ 4775 printed Dec 13, 2024@02:33:54 Page 2
RMPRAINQ ;PHX/JLT/HNB -Print History, Vehicle of Reg. ;1/30/1995
+1 ;;3.0;PROSTHETICS;**20,90**;Feb 09, 1996
+2 DO GETPAT^RMPRUTIL
if '$DATA(RMPRDFN)
QUIT
+3 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO EXIT
+4 IF $DATA(IO("Q"))
KILL IO("Q")
Begin DoDot:1
+5 SET ZTRTN="DU^RMPRAINQ"
SET ZTDESC="PROSTHETICS INQUIRE TO PATIENT VEHICLE OF RECORD"
SET ZTIO=ION
+6 FOR RMPRB="RMPRDFN","RMPRNAM","RMPRSSN"
SET ZTSAVE(RMPRB)=""
+7 DO ^%ZTLOAD
End DoDot:1
+8 IF $DATA(ZTSK)
GOTO EXIT
DU ;PRINT AUTO-ADAPTIVE EQUIPMENT, entry point from ??
+1 NEW PAGE,RMPRL,RMPRI,RMPRT,RMPRD,RDAT,RMPRB,FL
+2 ;K RMPRBACK
+3 SET DFN=RMPRDFN
DO ELIG^VADPT
SET RMPRCNUM=VAEL(7)
KILL VAEL
+4 SET PAGE=0
SET RMPRI=0
SET $PIECE(RMPRL,"-",IOM)=""
+5 USE IO
DO HDR
+6 FOR
SET RMPRI=$ORDER(^RMPR(667,"C",RMPRDFN,RMPRI))
if RMPRI'>0!($DATA(FL))
QUIT
Begin DoDot:1
+7 SET RMPRB=^RMPR(667,RMPRI,0)
+8 SET RMPRT=$ORDER(^RMPR(667,"B",$PIECE(RMPRB,U,1),0))
SET RMPRD=$PIECE(^RMPR(667,RMPRT,0),U,3)
+9 ;vehicle
+10 IF $DATA(^RMPR(667.3,"C",RMPRT))
DO LP
QUIT
+11 ;vehicle, no transactions
+12 SET RDAT=1
DO ONE
End DoDot:1
+13 if '$DATA(RDAT)
WRITE !!,?15,"NO VEHICLE OF RECORD FOR THIS PATIENT",!
+14 IF IOST["C-"
IF $Y<IOSL-5
FOR
WRITE !
if $Y>IOSL-5
QUIT
+15 IF IOST["C-"&('$DATA(FL))
KILL DIR
SET DIR(0)="E"
DO ^DIR
+16 WRITE @IOF
+17 ;
EXIT KILL DIC,RMPRINFO,RA,RK,RI,FL,DIR,Y,RMPRB
DO ^%ZISC
+1 IF $DATA(RMPRBACK)!($DATA(RMPRBAC1))
GOTO ASK1^RMPRPAT
+2 ;E K RMPRDFN,RMPRNAM,RMPRSSN,RMPRDOB,RMPRCNUM
+3 QUIT
LP ;find vehicle entries
+1 DO WR
WRITE !
NEW CNT,RPREV
SET RK=0
SET CNT=0
SET RPREV=0
+2 FOR
SET RK=$ORDER(^RMPR(667.3,"C",RMPRT,RK))
if RK'>0!($DATA(FL))
QUIT
Begin DoDot:1
+3 SET RDAT=1
DO WR1
End DoDot:1
+4 DO TOT
+5 QUIT
HDR SET PAGE=PAGE+1
+1 WRITE @IOF,!,"NAME: ",RMPRNAM,?33,"SSN: ",RMPRSSN
+2 WRITE ?50,"CLAIM NO. ",RMPRCNUM
+3 WRITE !,"VEHICLE ID#",?20,"YEAR",?25,"PURCHASE DATE",?40,"MAKE"
+4 WRITE ?51,"MODEL",?70,"PAGE ",PAGE
+5 WRITE !,"PROCESS DATE",?15,"ITEM",?40,"QTY",?51,"COST",?62,"AMIS"
+6 WRITE ?72,"TYPE",!?30,"'*' Denotes Inactive Vehicle of Record",!,RMPRL
+7 QUIT
WR IF IOST["C-"&($Y+6>IOSL)
SET DIR(0)="E"
DO ^DIR
IF 'Y
SET FL=1
QUIT
+1 if $Y+6>IOSL
DO HDR
IF $DATA(^RMPR(667,RMPRT,2))
IF $PIECE(^(2),U)=0
SET RMPRB="*"_RMPRB
PG ;display auto, no items
+1 WRITE !,$EXTRACT($PIECE(RMPRB,U,1),1,19),?20,$PIECE(RMPRB,U,5)
+2 SET Y=$PIECE(RMPRB,U,4)
DO DD^%DT
WRITE ?25,Y
+3 if +$PIECE(RMPRB,U,6)
WRITE ?40,$EXTRACT(^RMPR(667.2,$PIECE(RMPRB,U,6),0),1,9)
+4 WRITE ?51,$EXTRACT($PIECE(RMPRB,U,7),1,9)
+5 IF RMPRD
SET Y=RMPRD
DO DD^%DT
WRITE ?62,"4502: ",Y
+6 WRITE ?62,$SELECT($PIECE(RMPRB,U,9)="A":"ANKYLOSIS",$PIECE(RMPRB,U,9)="V":"VOC REHAB",1:"")
+7 IF $DATA(^RMPR(667,RMPRT,1,0))
SET RA=0
FOR
SET RA=$ORDER(^RMPR(667,RMPRT,1,RA))
if RA'>0
QUIT
WRITE !,^(RA,0)
+8 QUIT
WR1 ;items, or transactions
+1 IF IOST["C-"&($Y+6>IOSL)
SET DIR(0)="E"
DO ^DIR
IF 'Y
SET FL=1
QUIT
+2 IF $Y+6>IOSL
DO HDR
DO PG
WRITE !
+3 SET RMPRINFO=^RMPR(667.3,RK,0)
SET $PIECE(RMPRINFO,U,15)=+$PIECE(RMPRINFO,U,4)*+$PIECE(RMPRINFO,U,7)
+4 if '$PIECE(RMPRINFO,U,15)
SET $PIECE(RMPRINFO,U,15)=$PIECE(RMPRINFO,U,4)
+5 SET Y=$PIECE(RMPRINFO,U)
DO DD^%DT
+6 ;print total if process date different
+7 IF RPREV'=Y&(RPREV'=0)
DO TOT
+8 SET RPREV=Y
+9 WRITE !,Y
+10 WRITE ?15,$SELECT($DATA(^RMPR(667.1,+$PIECE(RMPRINFO,U,3),0)):$EXTRACT(^RMPR(667.1,$PIECE(RMPRINFO,U,3),0),1,20),1:"UNK")
+11 WRITE ?40,$PIECE(RMPRINFO,U,7),?48
+12 WRITE ?48+(10-($LENGTH($FNUMBER($PIECE(RMPRINFO,U,15),",",2)))),"$",$FNUMBER($PIECE(RMPRINFO,U,15),",",2)
+13 SET CNT=CNT+$PIECE(RMPRINFO,U,15)
+14 WRITE ?62,$SELECT($PIECE(RMPRINFO,U,5)["R":"REPAIR",$PIECE(RMPRINFO,U,5)["A":"VAN MOD",$PIECE(RMPRINFO,U,5)["B":"ADAP EQP",1:"")
+15 WRITE ?72,$SELECT($PIECE(RMPRINFO,U,8)="I":"INITIAL",$PIECE(RMPRINFO,U,8)="R":"REPLACE",$PIECE(RMPRINFO,U,8)="X":"REPAIR",$PIECE(RMPRINFO,U,8)="S":"SPARE",$PIECE(RMPRINFO,U,8)=5:"RENTAL",1:"")
+16 IF $DATA(^RMPR(667.3,RK,1,0))
Begin DoDot:1
+17 SET RA=0
+18 FOR
SET RA=$ORDER(^RMPR(667.3,RK,1,RA))
if RA'>0
QUIT
WRITE !,^(RA,0)
End DoDot:1
+19 QUIT
TOT if $DATA(FL)
QUIT
+1 WRITE !!?31,"Total/Date:"
+2 WRITE ?48+(10-$LENGTH($FNUMBER(CNT,",",2))),"$",$FNUMBER(CNT,",",2),!
+3 SET CNT=0
+4 QUIT
ONE ;vehicle, no items.
+1 IF IOST["C-"&($Y+6>IOSL)
SET DIR(0)="E"
DO ^DIR
IF 'Y
SET FL=1
QUIT
+2 if $Y+6>IOSL
DO HDR
+3 IF $DATA(^RMPR(667,RMPRT,2))
IF $PIECE(^(2),U)=0
SET RMPRB="*"_RMPRB
+4 WRITE !,$EXTRACT($PIECE(RMPRB,U,1),1,19),?20,$PIECE(RMPRB,U,5)
+5 SET Y=$PIECE(RMPRB,U,4)
DO DD^%DT
WRITE ?25,Y
+6 if $PIECE(RMPRB,U,6)
WRITE ?40,$SELECT($DATA(^RMPR(667.2,+$PIECE(RMPRB,U,6),0)):$EXTRACT(^RMPR(667.2,$PIECE(RMPRB,U,6),0),1,9),1:"UNK")
+7 WRITE ?51,$EXTRACT($PIECE(RMPRB,U,7),1,9)
+8 IF RMPRD
SET Y=RMPRD
DO DD^%DT
WRITE ?62,"4502: ",Y
+9 WRITE ?62,$SELECT($PIECE(RMPRB,U,9)="A":"ANKYLOSIS",$PIECE(RMPRB,U,9)="V":"VOC REHAB",1:"")
+10 IF $DATA(^RMPR(667,RMPRT,1,0))
SET RA=0
FOR
SET RA=$ORDER(^RMPR(667,RMPRT,1,RA))
if RA'>0
QUIT
WRITE !,^(RA,0)
+11 ;K DIR S DIR(0)="E" D ^DIR Q:$D(DUOUT)!($D(DTOUT)) W @IOF
WRITE !?15,"NO ITEMS ON THIS VEHICLE OF RECORD",!,RMPRL
+12 QUIT
VOR ;EDIT/DELETE VEHICLE OF RECORD
+1 KILL DIC,DIE,DA,DIK,RMPRA,DR
DO DIV4^RMPRSIT
IF $DATA(X)
QUIT
VH SET DIC=667
SET DIC(0)="AEQMNZ"
+1 SET DIC("A")="Please Enter Patient Name or Vehicle ID#: "
+2 SET DIC("W")="D LK^RMPRAVR"
+3 SET DIC("S")="I $P(^(0),U,10)=RMPR(""STA"")"
+4 IF RMPRSITE=1
SET DIC("S")=DIC("S")_"!($P(^(0),U,10)="""")"
+5 DO ^DIC
IF +Y'>0
KILL DIC,Y
QUIT
+6 LOCK +^RMPR(667,+Y,0):1
+7 IF $TEST=0
WRITE ?5,$CHAR(7),!,"Someone else is Editing this Entry!"
KILL DIC,Y
QUIT
+8 SET (RMPRDA,DA)=+Y
SET DR=".01;9STATUS;10;2;2.1;3;4;5;6;7;11;2.2;2.3;I $P(^RMPR(667,DA,2),U,3)'=4 S Y="""";2.4"
+9 SET DIE=DIC
DO ^DIE
+10 IF '$DATA(DA)
SET RI=0
FOR
SET RI=$ORDER(^RMPR(667.3,"C",RMPRDA,RI))
if RI'>0
QUIT
SET DA=RI
SET DIK="^RMPR(667.3,"
DO ^DIK
+11 WRITE !
LOCK -^RMPR(667,RMPRDA,0)
KILL DR,DIE
GOTO VH
