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

RMPR121B.m

Go to the documentation of this file. 
  1. RMPR121B ;PHX/HNC -POST GUI PURCHASE ORDER TRANSACTION ;3/1/2003
  1.  ;;3.0;PROSTHETICS;**90,75,137,147,151,153**;FEB 09,1996;Build 10
  1.  ;Per VHA Directive 2004-038, this routine should not be modified.
  1. A1(SIG,RMPRA,RMPRSITE) S RMPRGUI=1 G A2
  1. GUI(RESULT,SIG,RMPRA,RMPRSITE,RMPRPTR) ;
  1. A2 I (SIG="")!($E(SIG)="^") S RESULT=1_"^"_"Not Valid, Try Again..." Q
  1.  K RESULT D SIGN
  1.  Q
  1.  ;
  1. SIGN ; Validate /es/-code
  1.  ;
  1.  S X=SIG
  1.  S RMPRY=0
  1.  D HASH^XUSHSHP I X]"",(X=$P($G(^VA(200,+DUZ,20)),U,4)) S RMPRY=1
  1.  I RMPRY=0 S RESULT=1_"^"_"Checked signature Not Valid, Try Again..." Q
  1.  ;
  1.  S RMPRV=$P(^RMPR(664,RMPRA,0),U,4)
  1.  S RMPRPER=$P(^RMPR(664,RMPRA,2),U,6)/100
  1.  D GUIVAR
  1.  S PRCRMPR=1,X=1
  1.  D UP1^PRCH7PUC(.X,PRCA,PRCB,PRCC,PRCSITE,PRCVEN,PRCRMPR)
  1.  I X="^"!(X="#") D C664 G QUIT
  1.  S PRC442=$P(^RMPR(664,RMPRA,4),U,6)
  1.  I $P(^PRC(442,PRC442,7),U,1)'=6 G QUT
  1.  S $P(^RMPR(664,RMPRA,0),U,5)="",$P(^RMPR(664,RMPRA,2),U)="",$P(^RMPR(664,RMPRA,2),U,2)=""
  1.  I $D(RMPRPSC) S $P(^RMPR(664,RMPRA,2),U,5)=RMPRPSC
  1.  S RMPRPCD=$P(^RMPR(664,RMPRA,4),U,1),$P(^RMPR(664,RMPRA,4),U,1)=$$ENC^RMPR4LI(RMPRPCD,DUZ,RMPRA)
  1.  S DA=RMPRA,DIK="^RMPR(664," D IX1^DIK
  1.  ;get AMIS grouper number
  1.  L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G GGC
  1.  S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1,$P(^(0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0)
  1.  ;
  1. GGC S B2=0
  1.  F  S B2=$O(^RMPR(664,RMPRA,1,B2)) Q:B2'>0  D R19^RMPR121C
  1.  K RMPRDP
  1.  ; Shipping Record
  1.  I +RMPRSH'>0 G NS
  1.  K DD,DO S X=DT,DIC="^RMPR(660,",DIC(0)="LZ" D FILE^DICN K DIC,D0 S (RMPR660,DA)=+Y
  1.  S RMPRTRN=$P(^RMPR(664,RMPRA,4),U,5)
  1.  S $P(^RMPR(660,RMPR660,4),U,3)=RMPRV
  1.  S ^RMPR(660,RMPR660,0)=DT_U_RMPRDFN_U_DT_"^X^^^^^"_U_RMPR("STA")_"^^^14"_U_RMPRS_"^^"_RMPRSH_"^"_RMPRSH_"^^^^^",^("AMS")=RMPRG,^("AM")=U_U_RMPRDIS_U_RMPRSC,$P(^(0),U,27)=DUZ
  1.  ; /SPS Removed the following 2 lines for 75 may re-use at a later time
  1.  ; I $D(RMPRWO),RMPRWO S $P(^("AM"),U,2)=1 D
  1.  ;.I $D(^RMPR(664.2,RMPRWO,0)) S $P(^(0),U,6)=$P(^(0),U,6)+RMPRSH
  1.  S:$D(RMPRDELN) ^RMPR(660,RMPR660,3)=RMPRDELN S ^(1)=RMPRTRN
  1.  S DIK="^RMPR(660," D IX1^DIK S $P(^RMPR(664,RMPRA,0),U,12)=RMPR660 K RMPRDP
  1. NS S $P(^RMPR(664,RMPRA,2),U,4)="2421PC"
  1.  S RESULT=0_"^"_"PO COMPLETE"
  1.  S ^TMP("SPS",0)=RMPRPTR
  1.  I RMPRPTR=0 S RMPRPRIV=1 D ^RMPR4P21
  1.  I +RMPRPTR>0 S RMPRPRIV=1 D EN1^RMPR4P21(RMPRPTR)
  1.  K RMPRPRIV
  1.  Q
  1. QUIT ; Quit where IFCAP encountered a problem
  1.  S:XBAD="^" RESULT=1_"^"_"**STAND BY**  Your IFCAP order may be canceled due to a lack of funds. If you can immediately get an increase of funds re-enter your e-sig and complete this PO.  IF YOU LEAVE THIS SCREEN YOUR PO WILL BE LOST"
  1.  S:XBAD="#" RESULT="1^Your IFCAP order has been cancelled due to reaching the max seq for the Fund Control Point Activity requisition."
  1.  Q
  1. QUT ;
  1.  S RESULT="1^IFCAP did not update your Purchase Order, Please Log out and start over."
  1.  Q
  1. GUIVAR ; Get variable setup from the GUI application
  1.  ; Setup Site Variables
  1.  D INF^RMPRSIT
  1.  ; Shipping info
  1.  S $P(^RMPR(664,RMPRA,0),U,14)=RMPR("STA")
  1.  S (R1,RMPRCT,RMPRQT,RMPRTO,RMPRI,RMPRR)=0
  1.  S RMPRSH=$S($P(^RMPR(664,RMPRA,0),U,10):$P(^(0),U,10),1:"")
  1.  F  S R1=$O(^RMPR(664,RMPRA,1,R1)) Q:R1'>0  D
  1.  .S RB=^RMPR(664,RMPRA,1,R1,0)
  1.  .S RMPRCT=$P(RB,U,3)
  1.  .S RMPRQT=$P(RB,U,4)
  1.  .S RMPRR=$P(RB,U,8) ;REMARKS
  1.  .S RMPRTO=RMPRTO+$J(RMPRCT*RMPRQT,0,2)
  1.  S RMPRTOTC=$P($G(^RMPR(664,RMPRA,4)),U,3)
  1.  S PRCA=RMPRA
  1.  S PRCB=$P(^RMPR(664,RMPRA,4),U,6)
  1.  S PRCC=RMPRTOTC
  1.  S PRCSITE=$P(^RMPR(664,RMPRA,0),U,14)
  1.  S PRCVEN=$P(^RMPR(664,RMPRA,0),U,4)
  1.  S RMPRDFN=$P(^RMPR(664,RMPRA,0),U,2)
  1.  S RMPRPPA=$P(^VA(200,DUZ,1),U,9)
  1.  ; Setup Delivery to Variables
  1.  S RMPRY(0)=$P($G(^RMPR(664,RMPRA,3)),U)
  1. TST S RMPRY=$S(RMPRY(0)="VETERAN":1,RMPRY(0)="PROSTHETICS":2,RMPRY(0)="OTHER LOCATION AT THIS SITE":3,RMPRY(0)="OTHER LOCATION NOT AT THIS SITE":4,1:"")
  1.  D DELIV^RMPR121A
  1.  Q
  1. C664 ;CANCEL 664 ENTRY WHEN IFCAP IS CANCELLED
  1.  S XBAD=X
  1.  S $P(^RMPR(664,RMPRA,0),U,5)=$P(^RMPR(664,RMPRA,0),U),$P(^RMPR(664,RMPRA,2),U,2)=+DUZ
  1.  S WDS="INSUFF FUNDS CANCEL" S:XBAD="#" WDS="Max FCP req seq reached"
  1.  S DA=RMPRA,DR="3.1////^S X=WDS",DIE="^RMPR(664," D ^DIE K WDS
  1.  Q