RMPRM ;PHX/DWL-INFORMATION MESSAGES / PURCHASING FUNCTIONS ; 5/22/00 4:16pm
;;3.0;PROSTHETICS;**3,49**;Feb 09, 1996
;Per VHA Directive 10-93-142, this routine should not be modified.
;THE FIRST THREE LINES DISPLAY MESSAGES FOR THE USER FROM PURCHASING
M1 W !,$C(7),$C(7),"This Transaction has been Closed!" Q
M2 ;ENTRY POINT TO DISPLAY Canceled TRANSACTION MESSAGE
W !,$C(7),$C(7),"This Transaction has already been Canceled!" Q
M3 W !,$C(7),$C(7),"An X in the Item column is an error and must be reported to your Application Coordinator!" Q
;RETURNS PSC AMT IN RMPRAMT FROM SITE PARAMATER FILE
EN2520 ;ENTRY POINT FOR 2520 FORM TO SELECT PSC ITEM CATEGORY
W !,"Enter 'W' for WHEELCHAIR, 'O' for BRACE, 'B' for BLIND AIDS, 'A' for ART. LIMBS"
R !,"Select PSC ITEM CATEGORY: ",RMPRPSC:DTIME G:('$T)!(RMPRPSC["^") EXIT G:(RMPRPSC="") HPSC G:(RMPRPSC?."W")!(RMPRPSC?."B")!(RMPRPSC?."A")!(RMPRPSC?."O") PSCAMT G HPSC
PSCAMT ;CHECKS FOR DOLLAR LIMITATIONS IN SITE PARAMETER FILE-
;FOR PSC PURCHASE BY CATEGORY
S RMPRAMT=$S(RMPRPSC["B":$P(^RMPR(669.9,RMPRSITE,2),U,10),RMPRPSC["O":$P(^RMPR(669.9,RMPRSITE,2),U,9),RMPRPSC["W":$P(^RMPR(669.9,RMPRSITE,2),U,8),RMPRPSC["A":$P(^RMPR(669.9,RMPRSITE,2),U,7),1:0) I $D(RMPRF),RMPRF="E" Q
W !,"You will not be able to exceed an item repair cost of more than $",$J(RMPRAMT,0,2),"."
Q
HPSC W !,$C(7),$C(7),"??",!,"CHOOSE FROM:",!?5,"W",?15,"WHEELCHAIR",!?5,"O",?15,"BRACE",!?5,"B",?15,"BLIND AID",!?5,"A",?15,"ARTIFICIAL LIMB" G EN2520
EXIT K RMPRPSC,RMPRF Q
POST2 ;1358
S (R1,RMPR("AMT"),AMT)=0
I $D(^RMPR(664,RMPRA,2)),$P(^(2),U,6) S DCT=$P(^(2),U,6),DCT=DCT/100 F RI=0:0 S RI=$O(^RMPR(664,RMPRA,1,RI)) Q:RI'>0 D
.S RMX=^RMPR(664,RMPRA,1,RI,0) S $P(^(0),U,7)=$S($P(RMX,U,7):$P(RMX,U,7)-$J($P(RMX,U,7)*DCT,0,2),1:$P(RMX,U,3)-$J($P(RMX,U,3)*DCT,0,2))
S RMPRCC=""
F S R1=$O(^RMPR(664,RMPRA,1,R1)) Q:R1'>0 D
.S R2=^RMPR(664,RMPRA,1,R1,0)
.;remarks in RMPRCC from all items at this point
.S RMPRCC=$S($P(^RMPR(664,RMPRA,1,R1,0),U,8)'="":RMPRCC_" "_$P(^RMPR(664,RMPRA,1,R1,0),U,8),1:"")
.I $P(R2,U,7)'="" S AMT=$P(R2,U,7)
.E S AMT=$P(R2,U,3)
.;S AMT=$S($P(R2,U,7):$P(R2,U,7),1:$P(R2,U,3))
.S RMPR("AMT")=RMPR("AMT")+$J((AMT*$P(R2,U,4)),0,2)
.I '$D(RMPRCONT),$P(^(0),U,14)'="" S RMPRCONT=$P(^(0),U,14)
S RMPRTO=RMPR("AMT") D CHECK^RMPRCT
I '$D(RMPRTO) G EXIT^RMPRE21
D NOW^%DTC S RMPR("DDT")=%
S $P(^RMPR(664,RMPRA,0),U,8)=RMPR("DDT")
S B2=^RMPR(664,RMPRA,0)
K DIC S DIC=424,DIC(0)="MZ",X=$P(B2,U,7) D ^DIC
S RMPR("DRN")=+Y
S B2=^RMPR(664,RMPRA,0)
S RMPRSH=$S($P(B2,U,11)'="":+$P(B2,U,11),$P(B2,U,10):+$P(B2,U,10),1:"")
S DIE="^RMPR(664,",DA=RMPRA,DR="8.1" D ^DIE
;close-out remarks added to item remarks, stored as one comment
S RMPRCC=RMPRCC_" "_$P($G(^RMPR(664,RMPRA,2)),U,3)
;strip all leading spaces in remarks before calling IFCAP
N STOP,CC
S STOP="",CC=""
F CC=0:1:$L(RMPRCC) D Q:STOP
.I $E(RMPRCC,1,1)'=" " S STOP=1
.I $E(RMPRCC,1,1)=" " S RMPRCC=$E(RMPRCC,2,$L(RMPRCC))
I RMPRF=10 K DIE S DIE="^RMPR(660,",DA=RMPR660,DR=9 I $D(RMPRSR) S RO=0 I $O(RMPRSR(RO)) S RO=$O(RMPRSR(RO)) D
.S DR="9//^S X=RMPRSR(RO)"
.D ^DIE S RMPRSER=$P(^RMPR(660,RMPR660,0),U,11)
D NOW^%DTC
S PRCSX=RMPR("DRN")_U_%_U_$J(RMPR("AMT")+RMPRSH,0,2)_U_RMPRCC_U_1
D ^PRCS58CC
K RMPRCC
I +Y'>0 S $P(^RMPR(664,RMPRA,0),U,8)="",$P(^(0),U,11)="" W !,$C(7),$C(7),"Transaction NOT Closed-out, IFCAP Failed to Post for the Following Reason.",!,$P(Y,U,2)
I S R1=0 G EXIT^RMPRE21
S RMPRWO=$P(^RMPR(664,RMPRA,0),U,15)
I RMPRWO,$D(^RMPR(664.2,+RMPRWO,0)) S DA(1)=RMPRWO F DA=0:0 S DA=$O(^RMPR(664.2,RMPRWO,1,"AC",RMPRA,DA)) Q:DA'>0 S DIK="^RMPR(664.2,"_RMPRWO_",1,",DA(1)=RMPRWO D ^DIK
G POST1^RMPRE21
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRM 3721 printed Apr 09, 2024@21:38:43 Page 2
RMPRM ;PHX/DWL-INFORMATION MESSAGES / PURCHASING FUNCTIONS ; 5/22/00 4:16pm
+1 ;;3.0;PROSTHETICS;**3,49**;Feb 09, 1996
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;THE FIRST THREE LINES DISPLAY MESSAGES FOR THE USER FROM PURCHASING
M1 WRITE !,$CHAR(7),$CHAR(7),"This Transaction has been Closed!"
QUIT
M2 ;ENTRY POINT TO DISPLAY Canceled TRANSACTION MESSAGE
+1 WRITE !,$CHAR(7),$CHAR(7),"This Transaction has already been Canceled!"
QUIT
M3 WRITE !,$CHAR(7),$CHAR(7),"An X in the Item column is an error and must be reported to your Application Coordinator!"
QUIT
+1 ;RETURNS PSC AMT IN RMPRAMT FROM SITE PARAMATER FILE
EN2520 ;ENTRY POINT FOR 2520 FORM TO SELECT PSC ITEM CATEGORY
+1 WRITE !,"Enter 'W' for WHEELCHAIR, 'O' for BRACE, 'B' for BLIND AIDS, 'A' for ART. LIMBS"
+2 READ !,"Select PSC ITEM CATEGORY: ",RMPRPSC:DTIME
if ('$TEST)!(RMPRPSC["^")
GOTO EXIT
if (RMPRPSC="")
GOTO HPSC
if (RMPRPSC?."W")!(RMPRPSC?."B")!(RMPRPSC?."A")!(RMPRPSC?."O")
GOTO PSCAMT
GOTO HPSC
PSCAMT ;CHECKS FOR DOLLAR LIMITATIONS IN SITE PARAMETER FILE-
+1 ;FOR PSC PURCHASE BY CATEGORY
+2 SET RMPRAMT=$SELECT(RMPRPSC["B":$PIECE(^RMPR(669.9,RMPRSITE,2),U,10),RMPRPSC["O":$PIECE(^RMPR(669.9,RMPRSITE,2),U,9),RMPRPSC["W":$PIECE(^RMPR(669.9,RMPRSITE,2),U,8),RMPRPSC["A":$PIECE(^RMPR(669.9,RMPRSITE,2),U,7),1:0)
IF $DATA(RMPRF)
IF RMPRF="E"
QUIT
+3 WRITE !,"You will not be able to exceed an item repair cost of more than $",$JUSTIFY(RMPRAMT,0,2),"."
+4 QUIT
HPSC WRITE !,$CHAR(7),$CHAR(7),"??",!,"CHOOSE FROM:",!?5,"W",?15,"WHEELCHAIR",!?5,"O",?15,"BRACE",!?5,"B",?15,"BLIND AID",!?5,"A",?15,"ARTIFICIAL LIMB"
GOTO EN2520
EXIT KILL RMPRPSC,RMPRF
QUIT
POST2 ;1358
+1 SET (R1,RMPR("AMT"),AMT)=0
+2 IF $DATA(^RMPR(664,RMPRA,2))
IF $PIECE(^(2),U,6)
SET DCT=$PIECE(^(2),U,6)
SET DCT=DCT/100
FOR RI=0:0
SET RI=$ORDER(^RMPR(664,RMPRA,1,RI))
if RI'>0
QUIT
Begin DoDot:1
+3 SET RMX=^RMPR(664,RMPRA,1,RI,0)
SET $PIECE(^(0),U,7)=$SELECT($PIECE(RMX,U,7):$PIECE(RMX,U,7)-$JUSTIFY($PIECE(RMX,U,7)*DCT,0,2),1:$PIECE(RMX,U,3)-$JUSTIFY($PIECE(RMX,U,3)*DCT,0,2))
End DoDot:1
+4 SET RMPRCC=""
+5 FOR
SET R1=$ORDER(^RMPR(664,RMPRA,1,R1))
if R1'>0
QUIT
Begin DoDot:1
+6 SET R2=^RMPR(664,RMPRA,1,R1,0)
+7 ;remarks in RMPRCC from all items at this point
+8 SET RMPRCC=$SELECT($PIECE(^RMPR(664,RMPRA,1,R1,0),U,8)'="":RMPRCC_" "_$PIECE(^RMPR(664,RMPRA,1,R1,0),U,8),1:"")
+9 IF $PIECE(R2,U,7)'=""
SET AMT=$PIECE(R2,U,7)
+10 IF '$TEST
SET AMT=$PIECE(R2,U,3)
+11 ;S AMT=$S($P(R2,U,7):$P(R2,U,7),1:$P(R2,U,3))
+12 SET RMPR("AMT")=RMPR("AMT")+$JUSTIFY((AMT*$PIECE(R2,U,4)),0,2)
+13 IF '$DATA(RMPRCONT)
IF $PIECE(^(0),U,14)'=""
SET RMPRCONT=$PIECE(^(0),U,14)
End DoDot:1
+14 SET RMPRTO=RMPR("AMT")
DO CHECK^RMPRCT
+15 IF '$DATA(RMPRTO)
GOTO EXIT^RMPRE21
+16 DO NOW^%DTC
SET RMPR("DDT")=%
+17 SET $PIECE(^RMPR(664,RMPRA,0),U,8)=RMPR("DDT")
+18 SET B2=^RMPR(664,RMPRA,0)
+19 KILL DIC
SET DIC=424
SET DIC(0)="MZ"
SET X=$PIECE(B2,U,7)
DO ^DIC
+20 SET RMPR("DRN")=+Y
+21 SET B2=^RMPR(664,RMPRA,0)
+22 SET RMPRSH=$SELECT($PIECE(B2,U,11)'="":+$PIECE(B2,U,11),$PIECE(B2,U,10):+$PIECE(B2,U,10),1:"")
+23 SET DIE="^RMPR(664,"
SET DA=RMPRA
SET DR="8.1"
DO ^DIE
+24 ;close-out remarks added to item remarks, stored as one comment
+25 SET RMPRCC=RMPRCC_" "_$PIECE($GET(^RMPR(664,RMPRA,2)),U,3)
+26 ;strip all leading spaces in remarks before calling IFCAP
+27 NEW STOP,CC
+28 SET STOP=""
SET CC=""
+29 FOR CC=0:1:$LENGTH(RMPRCC)
Begin DoDot:1
+30 IF $EXTRACT(RMPRCC,1,1)'=" "
SET STOP=1
+31 IF $EXTRACT(RMPRCC,1,1)=" "
SET RMPRCC=$EXTRACT(RMPRCC,2,$LENGTH(RMPRCC))
End DoDot:1
if STOP
QUIT
+32 IF RMPRF=10
KILL DIE
SET DIE="^RMPR(660,"
SET DA=RMPR660
SET DR=9
IF $DATA(RMPRSR)
SET RO=0
IF $ORDER(RMPRSR(RO))
SET RO=$ORDER(RMPRSR(RO))
Begin DoDot:1
+33 SET DR="9//^S X=RMPRSR(RO)"
+34 DO ^DIE
SET RMPRSER=$PIECE(^RMPR(660,RMPR660,0),U,11)
End DoDot:1
+35 DO NOW^%DTC
+36 SET PRCSX=RMPR("DRN")_U_%_U_$JUSTIFY(RMPR("AMT")+RMPRSH,0,2)_U_RMPRCC_U_1
+37 DO ^PRCS58CC
+38 KILL RMPRCC
+39 IF +Y'>0
SET $PIECE(^RMPR(664,RMPRA,0),U,8)=""
SET $PIECE(^(0),U,11)=""
WRITE !,$CHAR(7),$CHAR(7),"Transaction NOT Closed-out, IFCAP Failed to Post for the Following Reason.",!,$PIECE(Y,U,2)
+40 IF $TEST
SET R1=0
GOTO EXIT^RMPRE21
+41 SET RMPRWO=$PIECE(^RMPR(664,RMPRA,0),U,15)
+42 IF RMPRWO
IF $DATA(^RMPR(664.2,+RMPRWO,0))
SET DA(1)=RMPRWO
FOR DA=0:0
SET DA=$ORDER(^RMPR(664.2,RMPRWO,1,"AC",RMPRA,DA))
if DA'>0
QUIT
SET DIK="^RMPR(664.2,"_RMPRWO_",1,"
SET DA(1)=RMPRWO
DO ^DIK
+43 GOTO POST1^RMPRE21
