RMPRL9 ;PHX/HNB-DISPLAY ITEMS ON 1358 TRANSACTION ;8/29/1994
;;3.0;PROSTHETICS;**19,90**;Feb 09, 1996
S:'$D(RMPRDELN) RMPRDELN="" S (RMPRI,RMPRCNT)=0,RMPRX="" D HOME^%ZIS W @IOF S:'$D(RMPRSER) RMPRSER=""
W ?0,$E($G(^UTILITY("DIQ1",$J,664.1,RMPRDA,.02)),1,30),?40,"WORK ORDER #: ",$G(^UTILITY("DIQ1",$J,664.1,RMPRDA,4))
S $P(LINE,"=",IOM)="",RZZZ=0
W !,LINE
LI F S RMPRI=$O(^RMPR(664,RMPRA,1,RMPRI)) Q:RMPRI'>0!($G(RMPRX)="^") S RMPRCNT=RMPRCNT+1,RMPRI1=^RMPR(664,RMPRA,1,RMPRI,0) D PRT
I $G(RMPRX)="^" I $Y<17 F W ! Q:$Y>17
I $G(RMPRX)="^" Q
W !,?25,"TOTAL COST: ",?65,"$",$J(RZZZ,0,2)
I $Y<17 F W ! Q:$Y>17
Q
PRT I RMPRCNT<0 W !,"NO ITEMS ON FILE" Q
W !!?5,"ITEM: "
S RMPRIT=$P(RMPRI1,U,1),RMPRIT1=$P(^RMPR(661,RMPRIT,0),U,1)
W $P(^PRC(441,RMPRIT1,0),U,1)," ",$P(^(0),U,2)," ",?45,"AMIS: " S RMPRAMIS=$S($P(RMPRI1,U,9)'="X":$P(^RMPR(661,RMPRIT,0),U,3),1:$P(^RMPR(661,RMPRIT,0),U,4))
W !!?5,"DESCRIPTION: ",$P(RMPRI1,U,2)
W !?5,"SERIAL NUMBER: " S RMPRSER=$S($P(^RMPR(664,RMPRA,1,RMPRI,0),U,15)]"":$P(^(0),U,15),$D(^RMPR(660,+$P(^(0),U,13),0)):$P(^(0),U,11),1:"") W RMPRSER
W !?5,"UNIT COST: ",$J($S($P(RMPRI1,U,7):$P(RMPRI1,U,7),1:$P(RMPRI1,U,3)),0,2),?25,"UNIT OF ISSUE: "
S RMPRU=$P(RMPRI1,U,5) W:RMPRU'="" $P(^PRCD(420.5,RMPRU,0),U,1),?45,"QTY: ",$P(RMPRI1,U,4),?55,"ITEM COST: "
S R1=$S($P(RMPRI1,U,7):$P(RMPRI1,U,7),1:$P(RMPRI1,U,3)),R2=$P(RMPRI1,U,4),RZZZ=RZZZ+(R1*R2) W $J(R1*R2,0,2)
W !?5,"TYPE: ",$S($P(RMPRI1,U,9)="X":"REPAIR",$P(RMPRI1,U,9)="I":"INITIAL",$P(RMPRI1,U,9)="R":"REPLACE",$P(RMPRI1,U,9)="S":"SPARE",$P(RMPRI1,U,9)="5":"RENTAL",1:"")
W ?25,"CATEGORY: ",$S($P(RMPRI1,U,10)=1:"SC/OP",$P(RMPRI1,U,10)=2:"SC/IP",$P(RMPRI1,U,10)=3:"NSC/IP",$P(RMPRI1,U,10)=4:"NSC/OP",1:"")
W ?44,"SPECIAL CATEGORY: "
W $S($P(RMPRI1,U,11)=1:"SPEC/LEG",$P(RMPRI1,U,11)=2:"A&A",$P(RMPRI1,U,11)=3:"PHC",$P(RMPRI1,U,11)=4:"ELIG/REF",1:"")
ASK I $Y>17 R !!,"Enter '^' to Quit Display, <Return> to Continue : ",RMPRX:DTIME S:'$T RMPRX="^" Q:RMPRX="^"
Q
C21 ;COMPLETE 2421 REQUEST FROM LAB
S RT=$O(^RMPR(664,RMPRA,1,0)) I RT>0,$D(^(RT,0)) S:$G(RMPRCONT)="" RMPRCONT=$P(^(0),U,14)
K FL D ^RMPRLI I RMPRX]"" G CHK
L2 W !! K DIR S DIR(0)="FO",DIR("A")="Select Item to Edit",DIR("?")="^S ZFL=1 D ZDSP^RMPR21A" D ^DIR G:$D(DTOUT) EXIT G:$D(DIRUT) COT S DIC="^RMPR(661,",DIC(0)="EQMZ" D ^DIC G:+Y'>0 L2
D EDT^RMPRUTIL G:$D(DTOUT) EXIT G L2
COT S DIE="^RMPR(664,",DR="4",DA=RMPRA D ^DIE I $D(DTOUT)!($D(Y)'=0) G CHK
S RMPRV=$P(^RMPR(664,RMPRA,0),U,4) G:'$D(^PRC(440,RMPRV,4)) L2 K DIR S DIR(0)="PO^PRC(440,"_RMPRV_",4,:QEM" S:$G(RMPRCONT)'="" DIR("B")=RMPRCONT D ^DIR I (Y'>0)&(X'="")&(X'["^") G COT
I X["^" G CHK
I Y>0,$P(^PRC(440,RMPRV,4,+Y,0),U,2)<DT W $C(7),!,"Sorry, contract has expired. Enter another contract or `return` to continue." G COT
K DIR,DA S:Y>0 (RMPRCONT,RMPRCTK)=$P(Y,U,2)
K DA S DIE="^RMPR(664,",DA=RMPRA,DR="11;17;20" D ^DIE G:$D(Y) CHK G:$D(DTOUT) EXIT
K DIR S:$G(RMPRDELN)'="" DIR("B")=RMPRDELN
S DIR(0)="SA^1:VETERAN;2:VAMC WAREHOUSE;3:PROSTHETICS;4:OTHER;",DIR("A")="DELIVER TO: "
D ^DIR G:$D(DIRUT) CHK G:$D(DTOUT) EXIT
S RMPRDELN=Y(0) I Y'=4 S $P(^RMPR(664,RMPRA,3),U)=RMPRDELN K RMPRDLC G CHK
S $P(^RMPR(664,RMPRA,3),U)=$S($G(RMPRDLC)'="":RMPRDLC,1:""),DIE="^RMPR(664,",DA=RMPRA,DR="19T" D ^DIE G:$D(DTOUT) EXIT S RMPRDLC=$P(^RMPR(664,RMPRA,3),U)
CHK S FL=1 I $D(^RMPR(664,RMPRA,1)) S FL=0 F RI=0:0 S RI=$O(^RMPR(664,RMPRA,1,RI)) Q:RI'>0 I $D(^(RI,0)) S FL=1 I $P(^(0),U,4)=""!($P(^(0),U,5)="")!($P(^(0),U,9)="")!($P(^(0),U,10)="") S FL=0 Q
I $P($G(^RMPR(664,RMPRA,3)),U)="" W !!,$C(7),"Deliver To information is Missing!! 2421 is incomplete" G EXIT
I 'FL W !!,?5,$C(7),"REQUIRED ITEM INFORMATION IS MISSING",! G EXIT
ASK5 S %=2 W !!,"Are you ready to POST to IFCAP and 10-2319 NOW" D YN^DICN G:%=1 FILE^RMPR21B G:$D(DTOUT) EXIT
I %=0 W !,"This will Create a Daily Transaction in the 1358 Module of IFCAP,",!,"and Create an Entry on the Prosthetic 10-2319 Record" G ASK5
I %'>0 S %=2 R !,"Do you want to delete the 2421 Request" D YN^DICN I $D(DTOUT)!(%=1) D DEL^RMPR29M(RMPRA) G KILL^RMPR21
G C21
EXIT I '$D(DTOUT) K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do You want to delete the 2421 Request" D ^DIR Q:$D(DTOUT) I +Y=1 D DEL^RMPR29M(RMPRA) G KILL^RMPR21
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRL9 4283 printed Sep 23, 2025@20:11:10 Page 2
RMPRL9 ;PHX/HNB-DISPLAY ITEMS ON 1358 TRANSACTION ;8/29/1994
+1 ;;3.0;PROSTHETICS;**19,90**;Feb 09, 1996
+2 if '$DATA(RMPRDELN)
SET RMPRDELN=""
SET (RMPRI,RMPRCNT)=0
SET RMPRX=""
DO HOME^%ZIS
WRITE @IOF
if '$DATA(RMPRSER)
SET RMPRSER=""
+3 WRITE ?0,$EXTRACT($GET(^UTILITY("DIQ1",$JOB,664.1,RMPRDA,.02)),1,30),?40,"WORK ORDER #: ",$GET(^UTILITY("DIQ1",$JOB,664.1,RMPRDA,4))
+4 SET $PIECE(LINE,"=",IOM)=""
SET RZZZ=0
+5 WRITE !,LINE
LI FOR
SET RMPRI=$ORDER(^RMPR(664,RMPRA,1,RMPRI))
if RMPRI'>0!($GET(RMPRX)="^")
QUIT
SET RMPRCNT=RMPRCNT+1
SET RMPRI1=^RMPR(664,RMPRA,1,RMPRI,0)
DO PRT
+1 IF $GET(RMPRX)="^"
IF $Y<17
FOR
WRITE !
if $Y>17
QUIT
+2 IF $GET(RMPRX)="^"
QUIT
+3 WRITE !,?25,"TOTAL COST: ",?65,"$",$JUSTIFY(RZZZ,0,2)
+4 IF $Y<17
FOR
WRITE !
if $Y>17
QUIT
+5 QUIT
PRT IF RMPRCNT<0
WRITE !,"NO ITEMS ON FILE"
QUIT
+1 WRITE !!?5,"ITEM: "
+2 SET RMPRIT=$PIECE(RMPRI1,U,1)
SET RMPRIT1=$PIECE(^RMPR(661,RMPRIT,0),U,1)
+3 WRITE $PIECE(^PRC(441,RMPRIT1,0),U,1)," ",$PIECE(^(0),U,2)," ",?45,"AMIS: "
SET RMPRAMIS=$SELECT($PIECE(RMPRI1,U,9)'="X":$PIECE(^RMPR(661,RMPRIT,0),U,3),1:$PIECE(^RMPR(661,RMPRIT,0),U,4))
+4 WRITE !!?5,"DESCRIPTION: ",$PIECE(RMPRI1,U,2)
+5 WRITE !?5,"SERIAL NUMBER: "
SET RMPRSER=$SELECT($PIECE(^RMPR(664,RMPRA,1,RMPRI,0),U,15)]"":$PIECE(^(0),U,15),$DATA(^RMPR(660,+$PIECE(^(0),U,13),0)):$PIECE(^(0),U,11),1:"")
WRITE RMPRSER
+6 WRITE !?5,"UNIT COST: ",$JUSTIFY($SELECT($PIECE(RMPRI1,U,7):$PIECE(RMPRI1,U,7),1:$PIECE(RMPRI1,U,3)),0,2),?25,"UNIT OF ISSUE: "
+7 SET RMPRU=$PIECE(RMPRI1,U,5)
if RMPRU'=""
WRITE $PIECE(^PRCD(420.5,RMPRU,0),U,1),?45,"QTY: ",$PIECE(RMPRI1,U,4),?55,"ITEM COST: "
+8 SET R1=$SELECT($PIECE(RMPRI1,U,7):$PIECE(RMPRI1,U,7),1:$PIECE(RMPRI1,U,3))
SET R2=$PIECE(RMPRI1,U,4)
SET RZZZ=RZZZ+(R1*R2)
WRITE $JUSTIFY(R1*R2,0,2)
+9 WRITE !?5,"TYPE: ",$SELECT($PIECE(RMPRI1,U,9)="X":"REPAIR",$PIECE(RMPRI1,U,9)="I":"INITIAL",$PIECE(RMPRI1,U,9)="R":"REPLACE",$PIECE(RMPRI1,U,9)="S":"SPARE",$PIECE(RMPRI1,U,9)="5":"RENTAL",1:"")
+10 WRITE ?25,"CATEGORY: ",$SELECT($PIECE(RMPRI1,U,10)=1:"SC/OP",$PIECE(RMPRI1,U,10)=2:"SC/IP",$PIECE(RMPRI1,U,10)=3:"NSC/IP",$PIECE(RMPRI1,U,10)=4:"NSC/OP",1:"")
+11 WRITE ?44,"SPECIAL CATEGORY: "
+12 WRITE $SELECT($PIECE(RMPRI1,U,11)=1:"SPEC/LEG",$PIECE(RMPRI1,U,11)=2:"A&A",$PIECE(RMPRI1,U,11)=3:"PHC",$PIECE(RMPRI1,U,11)=4:"ELIG/REF",1:"")
ASK IF $Y>17
READ !!,"Enter '^' to Quit Display, <Return> to Continue : ",RMPRX:DTIME
if '$TEST
SET RMPRX="^"
if RMPRX="^"
QUIT
+1 QUIT
C21 ;COMPLETE 2421 REQUEST FROM LAB
+1 SET RT=$ORDER(^RMPR(664,RMPRA,1,0))
IF RT>0
IF $DATA(^(RT,0))
if $GET(RMPRCONT)=""
SET RMPRCONT=$PIECE(^(0),U,14)
+2 KILL FL
DO ^RMPRLI
IF RMPRX]""
GOTO CHK
L2 WRITE !!
KILL DIR
SET DIR(0)="FO"
SET DIR("A")="Select Item to Edit"
SET DIR("?")="^S ZFL=1 D ZDSP^RMPR21A"
DO ^DIR
if $DATA(DTOUT)
GOTO EXIT
if $DATA(DIRUT)
GOTO COT
SET DIC="^RMPR(661,"
SET DIC(0)="EQMZ"
DO ^DIC
if +Y'>0
GOTO L2
+1 DO EDT^RMPRUTIL
if $DATA(DTOUT)
GOTO EXIT
GOTO L2
COT SET DIE="^RMPR(664,"
SET DR="4"
SET DA=RMPRA
DO ^DIE
IF $DATA(DTOUT)!($DATA(Y)'=0)
GOTO CHK
+1 SET RMPRV=$PIECE(^RMPR(664,RMPRA,0),U,4)
if '$DATA(^PRC(440,RMPRV,4))
GOTO L2
KILL DIR
SET DIR(0)="PO^PRC(440,"_RMPRV_",4,:QEM"
if $GET(RMPRCONT)'=""
SET DIR("B")=RMPRCONT
DO ^DIR
IF (Y'>0)&(X'="")&(X'["^")
GOTO COT
+2 IF X["^"
GOTO CHK
+3 IF Y>0
IF $PIECE(^PRC(440,RMPRV,4,+Y,0),U,2)<DT
WRITE $CHAR(7),!,"Sorry, contract has expired. Enter another contract or `return` to continue."
GOTO COT
+4 KILL DIR,DA
if Y>0
SET (RMPRCONT,RMPRCTK)=$PIECE(Y,U,2)
+5 KILL DA
SET DIE="^RMPR(664,"
SET DA=RMPRA
SET DR="11;17;20"
DO ^DIE
if $DATA(Y)
GOTO CHK
if $DATA(DTOUT)
GOTO EXIT
+6 KILL DIR
if $GET(RMPRDELN)'=""
SET DIR("B")=RMPRDELN
+7 SET DIR(0)="SA^1:VETERAN;2:VAMC WAREHOUSE;3:PROSTHETICS;4:OTHER;"
SET DIR("A")="DELIVER TO: "
+8 DO ^DIR
if $DATA(DIRUT)
GOTO CHK
if $DATA(DTOUT)
GOTO EXIT
+9 SET RMPRDELN=Y(0)
IF Y'=4
SET $PIECE(^RMPR(664,RMPRA,3),U)=RMPRDELN
KILL RMPRDLC
GOTO CHK
+10 SET $PIECE(^RMPR(664,RMPRA,3),U)=$SELECT($GET(RMPRDLC)'="":RMPRDLC,1:"")
SET DIE="^RMPR(664,"
SET DA=RMPRA
SET DR="19T"
DO ^DIE
if $DATA(DTOUT)
GOTO EXIT
SET RMPRDLC=$PIECE(^RMPR(664,RMPRA,3),U)
CHK SET FL=1
IF $DATA(^RMPR(664,RMPRA,1))
SET FL=0
FOR RI=0:0
SET RI=$ORDER(^RMPR(664,RMPRA,1,RI))
if RI'>0
QUIT
IF $DATA(^(RI,0))
SET FL=1
IF $PIECE(^(0),U,4)=""!($PIECE(^(0),U,5)="")!($PIECE(^(0),U,9)="")!($PIECE(^(0),U,10)="")
SET FL=0
QUIT
+1 IF $PIECE($GET(^RMPR(664,RMPRA,3)),U)=""
WRITE !!,$CHAR(7),"Deliver To information is Missing!! 2421 is incomplete"
GOTO EXIT
+2 IF 'FL
WRITE !!,?5,$CHAR(7),"REQUIRED ITEM INFORMATION IS MISSING",!
GOTO EXIT
ASK5 SET %=2
WRITE !!,"Are you ready to POST to IFCAP and 10-2319 NOW"
DO YN^DICN
if %=1
GOTO FILE^RMPR21B
if $DATA(DTOUT)
GOTO EXIT
+1 IF %=0
WRITE !,"This will Create a Daily Transaction in the 1358 Module of IFCAP,",!,"and Create an Entry on the Prosthetic 10-2319 Record"
GOTO ASK5
+2 IF %'>0
SET %=2
READ !,"Do you want to delete the 2421 Request"
DO YN^DICN
IF $DATA(DTOUT)!(%=1)
DO DEL^RMPR29M(RMPRA)
GOTO KILL^RMPR21
+3 GOTO C21
EXIT IF '$DATA(DTOUT)
KILL DIR
SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Do You want to delete the 2421 Request"
DO ^DIR
if $DATA(DTOUT)
QUIT
IF +Y=1
DO DEL^RMPR29M(RMPRA)
GOTO KILL^RMPR21
+1 QUIT
