Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RMPRM

RMPRM.m

Go to the documentation of this file.
  1. RMPRM ;PHX/DWL-INFORMATION MESSAGES / PURCHASING FUNCTIONS ; 5/22/00 4:16pm
  1. ;;3.0;PROSTHETICS;**3,49**;Feb 09, 1996
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;THE FIRST THREE LINES DISPLAY MESSAGES FOR THE USER FROM PURCHASING
  1. M1 W !,$C(7),$C(7),"This Transaction has been Closed!" Q
  1. M2 ;ENTRY POINT TO DISPLAY Canceled TRANSACTION MESSAGE
  1. W !,$C(7),$C(7),"This Transaction has already been Canceled!" Q
  1. M3 W !,$C(7),$C(7),"An X in the Item column is an error and must be reported to your Application Coordinator!" Q
  1. ;RETURNS PSC AMT IN RMPRAMT FROM SITE PARAMATER FILE
  1. EN2520 ;ENTRY POINT FOR 2520 FORM TO SELECT PSC ITEM CATEGORY
  1. W !,"Enter 'W' for WHEELCHAIR, 'O' for BRACE, 'B' for BLIND AIDS, 'A' for ART. LIMBS"
  1. 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
  1. PSCAMT ;CHECKS FOR DOLLAR LIMITATIONS IN SITE PARAMETER FILE-
  1. ;FOR PSC PURCHASE BY CATEGORY
  1. 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
  1. W !,"You will not be able to exceed an item repair cost of more than $",$J(RMPRAMT,0,2),"."
  1. Q
  1. 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
  1. EXIT K RMPRPSC,RMPRF Q
  1. POST2 ;1358
  1. S (R1,RMPR("AMT"),AMT)=0
  1. 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
  1. .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))
  1. S RMPRCC=""
  1. F S R1=$O(^RMPR(664,RMPRA,1,R1)) Q:R1'>0 D
  1. .S R2=^RMPR(664,RMPRA,1,R1,0)
  1. .;remarks in RMPRCC from all items at this point
  1. .S RMPRCC=$S($P(^RMPR(664,RMPRA,1,R1,0),U,8)'="":RMPRCC_" "_$P(^RMPR(664,RMPRA,1,R1,0),U,8),1:"")
  1. .I $P(R2,U,7)'="" S AMT=$P(R2,U,7)
  1. .E S AMT=$P(R2,U,3)
  1. .;S AMT=$S($P(R2,U,7):$P(R2,U,7),1:$P(R2,U,3))
  1. .S RMPR("AMT")=RMPR("AMT")+$J((AMT*$P(R2,U,4)),0,2)
  1. .I '$D(RMPRCONT),$P(^(0),U,14)'="" S RMPRCONT=$P(^(0),U,14)
  1. S RMPRTO=RMPR("AMT") D CHECK^RMPRCT
  1. I '$D(RMPRTO) G EXIT^RMPRE21
  1. D NOW^%DTC S RMPR("DDT")=%
  1. S $P(^RMPR(664,RMPRA,0),U,8)=RMPR("DDT")
  1. S B2=^RMPR(664,RMPRA,0)
  1. K DIC S DIC=424,DIC(0)="MZ",X=$P(B2,U,7) D ^DIC
  1. S RMPR("DRN")=+Y
  1. S B2=^RMPR(664,RMPRA,0)
  1. S RMPRSH=$S($P(B2,U,11)'="":+$P(B2,U,11),$P(B2,U,10):+$P(B2,U,10),1:"")
  1. S DIE="^RMPR(664,",DA=RMPRA,DR="8.1" D ^DIE
  1. ;close-out remarks added to item remarks, stored as one comment
  1. S RMPRCC=RMPRCC_" "_$P($G(^RMPR(664,RMPRA,2)),U,3)
  1. ;strip all leading spaces in remarks before calling IFCAP
  1. N STOP,CC
  1. S STOP="",CC=""
  1. F CC=0:1:$L(RMPRCC) D Q:STOP
  1. .I $E(RMPRCC,1,1)'=" " S STOP=1
  1. .I $E(RMPRCC,1,1)=" " S RMPRCC=$E(RMPRCC,2,$L(RMPRCC))
  1. 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
  1. .S DR="9//^S X=RMPRSR(RO)"
  1. .D ^DIE S RMPRSER=$P(^RMPR(660,RMPR660,0),U,11)
  1. D NOW^%DTC
  1. S PRCSX=RMPR("DRN")_U_%_U_$J(RMPR("AMT")+RMPRSH,0,2)_U_RMPRCC_U_1
  1. D ^PRCS58CC
  1. K RMPRCC
  1. 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)
  1. I S R1=0 G EXIT^RMPRE21
  1. S RMPRWO=$P(^RMPR(664,RMPRA,0),U,15)
  1. 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
  1. G POST1^RMPRE21