RMPRAUT ;PHX/JLT-AUTO ADAPTIVE EQUIPMENT ;8/29/1994
;;3.0;PROSTHETICS;;Feb 09, 1996
LOOK D DIV4^RMPRSIT,HOME^%ZIS G:$D(X) END D GETPAT^RMPRUTIL G:'$D(RMPRDFN) END S RMPR45=$S($D(^RMPR(667,"AD",RMPRDFN)):$O(^RMPR(667,"AD",RMPRDFN,0)),1:"") S Y=RMPR45 D DD^%DT
I Y'="" W !!,?20,"VAF21-4502 DATE: ",Y G EDT
K Y,DA
S DIR(0)="667,2" D ^DIR G:$D(DTOUT) END S:Y RMPR45=Y_U_"N"
ANK I $D(DIRUT),X'["^" S DIR(0)="667,2.1",DIR("A")="ANKLYOSIS OR VOC REHAB" D ^DIR G:$D(DUOUT) END S RMPRX=X K DIR I X="" W !!,?5,$C(7),"This is a required response. Enter '^' to exit.",! G ANK
K Y,DA,X
EDT S DIR(0)="667,3" D ^DIR G:$D(DTOUT)!($D(DIRUT)) END S RMPRC(1)=Y
S DIR(0)="667,4" D ^DIR G:$D(DTOUT)!($D(DIRUT)) END S RMPRC(2)=Y
MAK S DIC=667.2,DIC(0)="AEQMZ",DIC("A")="MAKE: " D ^DIC G:+Y'>0!(X["^")!($D(DTOUT)) END G:X[""&(Y'>0) MAK S RMPRC(3)=$S(Y'=-1:+Y,1:"")
K DIC,Y,DA S DIR(0)="667,6" D ^DIR G:$D(DTOUT)!($D(DIRUT)) END S RMPRC(4)=X
DPR S DIR("A")="VEHICLE ID#",DIR(0)="667,.01" D ^DIR G:$D(DTOUT)!($D(DIRUT)) END S RX=Y K DIR I $D(^RMPR(667,"B",RX)) F RA=0:0 S RA=$O(^RMPR(667,"B",RX,RA)) Q:RA'>0 I $D(^RMPR(667,RA,2)),$P(^(2),U) S RI=^RMPR(667,RA,0) D
.S DFN=$P(RI,U,2) D ^VADPT W !!,"Patient: ",$E(VADM(1),1,30),?40,VA("PID"),!!,"Has Vehicle ID#: ",$P(RI,U,1)," As an active Vehicle of Record"
.W !,?5,$C(7),"You must mark this Vehicle of Record Inactive before ",!,?5,"you can assign it to this Veteran. Use the Edit/Delete",!,?5,"Vehicle of Record option to do so" S FLG=1
I $D(FLG) G END
K DIC,Y S X=RX S DIC="^RMPR(667,",DIC(0)="EQZL",DLAYGO=667 D ^DIC K DLAYGO G:+Y'>0 END
CHK S RMPRDA=+Y,(RC,RB,RF,RLP)=0,RA="" K Y,DA I '$D(^RMPR(667,"C",RMPRDFN)) G ROV
D LP
G:RC'>1 ROV K DIR S DIR(0)="Y",DIR("B")="YES"
W !!,$C(7),?5,"There are currently two V.O.R in the last 4 yrs.",!,?5,"Are you going to apply the exception rule?"
EXP W ! D ^DIR I $D(DTOUT)!($D(DIRUT))!(Y=0) G DEL
ASK S RK=0 W ! D DSP
W ! K DIR S DIR(0)="N",DIR("A")="Please Enter Vehicle of Record entry # to be dropped",DIR("?")="Selecting an entry will mark the Vehicle inactive"
D ^DIR G:$D(DTOUT)!($D(DIRUT)) DEL I '$D(RAC(Y)) W $C(7) G ASK
I $D(^RMPR(667,+RAC(Y),2)),$P(^(2),U)=0 W $C(7),!!,?5,"INACTIVE RECORD" G ASK
L +^RMPR(667,+RAC(Y),0):1 I '$T W !,"Someone else is Editing this entry" G END
S $P(^RMPR(667,+RAC(Y),2),U)=0 K RFL S RY=Y,FL=+RAC(Y) S DA=+RAC(Y),DIE="^RMPR(667,",DR="10" D ^DIE L -^RMPR(667,+RAC(RY),0) K DIE,DIC,Y,DA G FILE
ROV I $D(RAC),RF>1 W !!,$C(7),?5,"This Patient Currently has two Vehicles of Record.",!,?5,"Would you like to drop a Vehicle?" S DIR(0)="Y",DIR("B")="YES" G EXP
FILE K DIR,Y S DIR(0)="667,7^^K:Y<RMPRC(1) X" D ^DIR G:$D(DTOUT)!($D(DIRUT)) DEL S RMPRC(5)=Y
K DIR,Y S DIR(0)="667,2.2" D ^DIR G:$D(DTOUT)!($D(DIRUT)) DEL S RMPRC(6)=Y
K DIR,Y S DIR(0)="667,2.3" D ^DIR G:$D(DTOUT)!($D(DIRUT)) DEL S RMPRC(7)=Y
S RMPRC(8)="" I RMPRC(7)=4 K DIR,Y S DIR(0)="667,2.4" D ^DIR I +Y S RMPRC(8)=Y
S $P(^RMPR(667,RMPRDA,0),U,2)=RMPRDFN S:$D(RMPRX) $P(^(0),U,9)=RMPRX S:$P(RMPR45,U,2)="N" $P(^(0),U,3)=$P(RMPR45,U)
S $P(^RMPR(667,RMPRDA,0),U,4)=RMPRC(1),$P(^(0),U,5)=RMPRC(2),$P(^(0),U,6)=RMPRC(3),$P(^(0),U,7)=RMPRC(4),$P(^(0),U,8)=RMPRC(5),$P(^(0),U,10)=RMPR("STA")
S ^RMPR(667,RMPRDA,2)=1_"^"_RMPRC(6)_"^"_RMPRC(7)_"^"_RMPRC(8)
S DA=RMPRDA,DIK="^RMPR(667," D IX1^DIK K Y,DA,FL
K DIR S DIR(0)="Y",DIR("A")="Would you like to enter the Auto adaptive equipment now"
D ^DIR G:$D(DTOUT)!($D(DIRUT))!(Y=0) END
W ! K DIR,Y S DIR(0)="S^A:21B;V:21A",DIR("A")="Enter 'A' for Adaptive items, 'V' for Van Mods" D ^DIR G:$D(DTOUT)!($D(DIRUT)) END S RMPRAM=Y(0) K DIR G ENT^RMPRAVR
END D:'$D(DTOUT) LINK^RMPRS
K DA,DIK,J,RMPRDA,REX,DIC,DIR,RMPR45,RMPRDFN,RMPRC,RAC,RZ,RB,RC,RA,X,RFL,FL,RF,RK,RD,RMPR45,RMPRAM,RMPRDFN,RMPRR,RE,DIR,DIRUT,DUOUT,RLP,RMPRDOB,RMPRNAM,RMPRSSN,RMPRDOD,FLG Q
DEL S DA=RMPRDA,DIK="^RMPR(667," D ^DIK W !!,$C(7),"Deleted..." S:$D(FL) ^RMPR(667,+FL,2)=1 D END
Q
DSP S RK=$O(RAC(RK)) Q:RK'>0 S RA=RAC(RK) W !,RK W:$P(RA,U,3) ?3,$E($P(^DPT($P(RA,U,3),0),U),1,20)," ",$P(RA,U,2) W:$P(RA,U,7) ?45,$E(^RMPR(667.2,$P(RA,U,7),0),1,10) W ?50,$E($P(RA,U,8),1,5) S Y=$P(RA,U,9) D DD^%DT W ?57,Y
I $D(^RMPR(667,+RAC(RK),2)) W ?69 W $S(+^(2)=1:"ACTIVE",1:"INACTIVE")
G DSP
LP S RB=$O(^RMPR(667,"C",RMPRDFN,RB)) Q:RB'>0 S REX=$S($D(^RMPR(667,RB,2)):$P(^(2),U),1:0)
I $P(^RMPR(667,RB,2),U)=1 S:$P(^RMPR(667,RB,0),U,8)'="" RZ=+$P(^(0),U,8) S RD=DT-RZ S:RD'>40000&(REX=1) RC=RC+1 S:REX=1 RF=RF+1 S RLP=RLP+1,RAC(RLP)=RB_"^"_^(0)
G LP
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRAUT 4508 printed Dec 13, 2024@02:33:56 Page 2
RMPRAUT ;PHX/JLT-AUTO ADAPTIVE EQUIPMENT ;8/29/1994
+1 ;;3.0;PROSTHETICS;;Feb 09, 1996
LOOK DO DIV4^RMPRSIT
DO HOME^%ZIS
if $DATA(X)
GOTO END
DO GETPAT^RMPRUTIL
if '$DATA(RMPRDFN)
GOTO END
SET RMPR45=$SELECT($DATA(^RMPR(667,"AD",RMPRDFN)):$ORDER(^RMPR(667,"AD",RMPRDFN,0)),1:"")
SET Y=RMPR45
DO DD^%DT
+1 IF Y'=""
WRITE !!,?20,"VAF21-4502 DATE: ",Y
GOTO EDT
+2 KILL Y,DA
+3 SET DIR(0)="667,2"
DO ^DIR
if $DATA(DTOUT)
GOTO END
if Y
SET RMPR45=Y_U_"N"
ANK IF $DATA(DIRUT)
IF X'["^"
SET DIR(0)="667,2.1"
SET DIR("A")="ANKLYOSIS OR VOC REHAB"
DO ^DIR
if $DATA(DUOUT)
GOTO END
SET RMPRX=X
KILL DIR
IF X=""
WRITE !!,?5,$CHAR(7),"This is a required response. Enter '^' to exit.",!
GOTO ANK
+1 KILL Y,DA,X
EDT SET DIR(0)="667,3"
DO ^DIR
if $DATA(DTOUT)!($DATA(DIRUT))
GOTO END
SET RMPRC(1)=Y
+1 SET DIR(0)="667,4"
DO ^DIR
if $DATA(DTOUT)!($DATA(DIRUT))
GOTO END
SET RMPRC(2)=Y
MAK SET DIC=667.2
SET DIC(0)="AEQMZ"
SET DIC("A")="MAKE: "
DO ^DIC
if +Y'>0!(X["^")!($DATA(DTOUT))
GOTO END
if X[""&(Y'>0)
GOTO MAK
SET RMPRC(3)=$SELECT(Y'=-1:+Y,1:"")
+1 KILL DIC,Y,DA
SET DIR(0)="667,6"
DO ^DIR
if $DATA(DTOUT)!($DATA(DIRUT))
GOTO END
SET RMPRC(4)=X
DPR SET DIR("A")="VEHICLE ID#"
SET DIR(0)="667,.01"
DO ^DIR
if $DATA(DTOUT)!($DATA(DIRUT))
GOTO END
SET RX=Y
KILL DIR
IF $DATA(^RMPR(667,"B",RX))
FOR RA=0:0
SET RA=$ORDER(^RMPR(667,"B",RX,RA))
if RA'>0
QUIT
IF $DATA(^RMPR(667,RA,2))
IF $PIECE(^(2),U)
SET RI=^RMPR(667,RA,0)
Begin DoDot:1
+1 SET DFN=$PIECE(RI,U,2)
DO ^VADPT
WRITE !!,"Patient: ",$EXTRACT(VADM(1),1,30),?40,VA("PID"),!!,"Has Vehicle ID#: ",$PIECE(RI,U,1)," As an active Vehicle of Record"
+2 WRITE !,?5,$CHAR(7),"You must mark this Vehicle of Record Inactive before ",!,?5,"you can assign it to this Veteran. Use the Edit/Delete",!,?5,"Vehicle of Record option to do so"
SET FLG=1
End DoDot:1
+3 IF $DATA(FLG)
GOTO END
+4 KILL DIC,Y
SET X=RX
SET DIC="^RMPR(667,"
SET DIC(0)="EQZL"
SET DLAYGO=667
DO ^DIC
KILL DLAYGO
if +Y'>0
GOTO END
CHK SET RMPRDA=+Y
SET (RC,RB,RF,RLP)=0
SET RA=""
KILL Y,DA
IF '$DATA(^RMPR(667,"C",RMPRDFN))
GOTO ROV
+1 DO LP
+2 if RC'>1
GOTO ROV
KILL DIR
SET DIR(0)="Y"
SET DIR("B")="YES"
+3 WRITE !!,$CHAR(7),?5,"There are currently two V.O.R in the last 4 yrs.",!,?5,"Are you going to apply the exception rule?"
EXP WRITE !
DO ^DIR
IF $DATA(DTOUT)!($DATA(DIRUT))!(Y=0)
GOTO DEL
ASK SET RK=0
WRITE !
DO DSP
+1 WRITE !
KILL DIR
SET DIR(0)="N"
SET DIR("A")="Please Enter Vehicle of Record entry # to be dropped"
SET DIR("?")="Selecting an entry will mark the Vehicle inactive"
+2 DO ^DIR
if $DATA(DTOUT)!($DATA(DIRUT))
GOTO DEL
IF '$DATA(RAC(Y))
WRITE $CHAR(7)
GOTO ASK
+3 IF $DATA(^RMPR(667,+RAC(Y),2))
IF $PIECE(^(2),U)=0
WRITE $CHAR(7),!!,?5,"INACTIVE RECORD"
GOTO ASK
+4 LOCK +^RMPR(667,+RAC(Y),0):1
IF '$TEST
WRITE !,"Someone else is Editing this entry"
GOTO END
+5 SET $PIECE(^RMPR(667,+RAC(Y),2),U)=0
KILL RFL
SET RY=Y
SET FL=+RAC(Y)
SET DA=+RAC(Y)
SET DIE="^RMPR(667,"
SET DR="10"
DO ^DIE
LOCK -^RMPR(667,+RAC(RY),0)
KILL DIE,DIC,Y,DA
GOTO FILE
ROV IF $DATA(RAC)
IF RF>1
WRITE !!,$CHAR(7),?5,"This Patient Currently has two Vehicles of Record.",!,?5,"Would you like to drop a Vehicle?"
SET DIR(0)="Y"
SET DIR("B")="YES"
GOTO EXP
FILE KILL DIR,Y
SET DIR(0)="667,7^^K:Y<RMPRC(1) X"
DO ^DIR
if $DATA(DTOUT)!($DATA(DIRUT))
GOTO DEL
SET RMPRC(5)=Y
+1 KILL DIR,Y
SET DIR(0)="667,2.2"
DO ^DIR
if $DATA(DTOUT)!($DATA(DIRUT))
GOTO DEL
SET RMPRC(6)=Y
+2 KILL DIR,Y
SET DIR(0)="667,2.3"
DO ^DIR
if $DATA(DTOUT)!($DATA(DIRUT))
GOTO DEL
SET RMPRC(7)=Y
+3 SET RMPRC(8)=""
IF RMPRC(7)=4
KILL DIR,Y
SET DIR(0)="667,2.4"
DO ^DIR
IF +Y
SET RMPRC(8)=Y
+4 SET $PIECE(^RMPR(667,RMPRDA,0),U,2)=RMPRDFN
if $DATA(RMPRX)
SET $PIECE(^(0),U,9)=RMPRX
if $PIECE(RMPR45,U,2)="N"
SET $PIECE(^(0),U,3)=$PIECE(RMPR45,U)
+5 SET $PIECE(^RMPR(667,RMPRDA,0),U,4)=RMPRC(1)
SET $PIECE(^(0),U,5)=RMPRC(2)
SET $PIECE(^(0),U,6)=RMPRC(3)
SET $PIECE(^(0),U,7)=RMPRC(4)
SET $PIECE(^(0),U,8)=RMPRC(5)
SET $PIECE(^(0),U,10)=RMPR("STA")
+6 SET ^RMPR(667,RMPRDA,2)=1_"^"_RMPRC(6)_"^"_RMPRC(7)_"^"_RMPRC(8)
+7 SET DA=RMPRDA
SET DIK="^RMPR(667,"
DO IX1^DIK
KILL Y,DA,FL
+8 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Would you like to enter the Auto adaptive equipment now"
+9 DO ^DIR
if $DATA(DTOUT)!($DATA(DIRUT))!(Y=0)
GOTO END
+10 WRITE !
KILL DIR,Y
SET DIR(0)="S^A:21B;V:21A"
SET DIR("A")="Enter 'A' for Adaptive items, 'V' for Van Mods"
DO ^DIR
if $DATA(DTOUT)!($DATA(DIRUT))
GOTO END
SET RMPRAM=Y(0)
KILL DIR
GOTO ENT^RMPRAVR
END if '$DATA(DTOUT)
DO LINK^RMPRS
+1 KILL DA,DIK,J,RMPRDA,REX,DIC,DIR,RMPR45,RMPRDFN,RMPRC,RAC,RZ,RB,RC,RA,X,RFL,FL,RF,RK,RD,RMPR45,RMPRAM,RMPRDFN,RMPRR,RE,DIR,DIRUT,DUOUT,RLP,RMPRDOB,RMPRNAM,RMPRSSN,RMPRDOD,FLG
QUIT
DEL SET DA=RMPRDA
SET DIK="^RMPR(667,"
DO ^DIK
WRITE !!,$CHAR(7),"Deleted..."
if $DATA(FL)
SET ^RMPR(667,+FL,2)=1
DO END
+1 QUIT
DSP SET RK=$ORDER(RAC(RK))
if RK'>0
QUIT
SET RA=RAC(RK)
WRITE !,RK
if $PIECE(RA,U,3)
WRITE ?3,$EXTRACT($PIECE(^DPT($PIECE(RA,U,3),0),U),1,20)," ",$PIECE(RA,U,2)
if $PIECE(RA,U,7)
WRITE ?45,$EXTRACT(^RMPR(667.2,$PIECE(RA,U,7),0),1,10)
WRITE ?50,$EXTRACT($PIECE(RA,U,8),1,5)
SET Y=$PIECE(RA,U,9)
DO DD^%DT
WRITE ?57,Y
+1 IF $DATA(^RMPR(667,+RAC(RK),2))
WRITE ?69
WRITE $SELECT(+^(2)=1:"ACTIVE",1:"INACTIVE")
+2 GOTO DSP
LP SET RB=$ORDER(^RMPR(667,"C",RMPRDFN,RB))
if RB'>0
QUIT
SET REX=$SELECT($DATA(^RMPR(667,RB,2)):$PIECE(^(2),U),1:0)
+1 IF $PIECE(^RMPR(667,RB,2),U)=1
if $PIECE(^RMPR(667,RB,0),U,8)'=""
SET RZ=+$PIECE(^(0),U,8)
SET RD=DT-RZ
if RD'>40000&(REX=1)
SET RC=RC+1
if REX=1
SET RF=RF+1
SET RLP=RLP+1
SET RAC(RLP)=RB_"^"_^(0)
+2 GOTO LP
