- 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 Feb 19, 2025@00:01:31 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