source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR121B.m@ 1094

RMPR121B ;PHX/HNC -POST GUI PURCHASE ORDER TRANSACTION ;3/1/2003
 ;;3.0;PROSTHETICS;**90,75,137**;FEB 09,1996;Build 5
 ;Per VHA Directive 10-93-142, this routine should not be modified.
A1(SIG,RMPRA,RMPRSITE) S RMPRGUI=1 G A2
GUI(RESULT,SIG,RMPRA,RMPRSITE,RMPRPTR) ;
A2 I (SIG="")!($E(SIG)="^") S RESULT=1_"^"_"Not Valid, Try Again..." Q
 K RESULT D SIGN
 Q
 ;
SIGN ; Validate /es/-code
 ;
 S X=SIG
 S RMPRY=0
 D HASH^XUSHSHP I X]"",(X=$P($G(^VA(200,+DUZ,20)),U,4)) S RMPRY=1
 I RMPRY=0 S RESULT=1_"^"_"Checked signature Not Valid, Try Again..." Q
 ;
 S RMPRV=$P(^RMPR(664,RMPRA,0),U,4)
 S RMPRPER=$P(^RMPR(664,RMPRA,2),U,6)/100
 D GUIVAR
 S PRCRMPR=1,X=1,PRCRMPR=1
 D UP1^PRCH7PUC(.X,PRCA,PRCB,PRCC,PRCSITE,PRCVEN,PRCRMPR)
 I X="^" D C664 G QUIT
 S PRC442=$P(^RMPR(664,RMPRA,4),U,6)
 I $P(^PRC(442,PRC442,7),U,1)'=6 G QUT
 S $P(^RMPR(664,RMPRA,0),U,5)="",$P(^RMPR(664,RMPRA,2),U)="",$P(^RMPR(664,RMPRA,2),U,2)=""
 I $D(RMPRPSC) S $P(^RMPR(664,RMPRA,2),U,5)=RMPRPSC
 S DA=RMPRA,DIK="^RMPR(664," D IX1^DIK
 ;get AMIS grouper number
 L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G GGC
 S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1,$P(^(0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0)
 ;
GGC S B2=0
 F  S B2=$O(^RMPR(664,RMPRA,1,B2)) Q:B2'>0  D R19^RMPR121C
 K RMPRDP
 ; Shipping Record
 I +RMPRSH'>0 G NS
 K DD,DO S X=DT,DIC="^RMPR(660,",DIC(0)="LZ" D FILE^DICN K DIC,D0 S (RMPR660,DA)=+Y
 S RMPRTRN=$P(^RMPR(664,RMPRA,4),U,5)
 S $P(^RMPR(660,RMPR660,4),U,3)=RMPRV
 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
 ; /SPS Removed the following 2 lines for 75 may re-use at a later time
 ; I $D(RMPRWO),RMPRWO S $P(^("AM"),U,2)=1 D
 ;.I $D(^RMPR(664.2,RMPRWO,0)) S $P(^(0),U,6)=$P(^(0),U,6)+RMPRSH
 S:$D(RMPRDELN) ^RMPR(660,RMPR660,3)=RMPRDELN S ^(1)=RMPRTRN
 S DIK="^RMPR(660," D IX1^DIK S $P(^RMPR(664,RMPRA,0),U,12)=RMPR660 K RMPRDP
NS S $P(^RMPR(664,RMPRA,2),U,4)="2421PC"
 S RESULT=0_"^"_"PO COMPLETE"
 S ^TMP("SPS",0)=RMPRPTR
 I RMPRPTR=0 D ^RMPR4P21
 I +RMPRPTR>0 D EN1^RMPR4P21(RMPRPTR)
 Q
QUIT ; Quit where IFCAP encountered a problem
 S 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"
 Q
QUT ;
 S RESULT="1^IFCAP did not update your Purchase Order, Please Log out and start over."
 Q
GUIVAR ; Get variable setup from the GUI application
 ; Setup Site Variables
 D INF^RMPRSIT
 ; Shipping info
 S $P(^RMPR(664,RMPRA,0),U,14)=RMPR("STA")
 S (R1,RMPRCT,RMPRQT,RMPRTO,RMPRI,RMPRR)=0
 S RMPRSH=$S($P(^RMPR(664,RMPRA,0),U,10):$P(^(0),U,10),1:"")
 F  S R1=$O(^RMPR(664,RMPRA,1,R1)) Q:R1'>0  D
 .S RB=^RMPR(664,RMPRA,1,R1,0)
 .S RMPRCT=$P(RB,U,3)
 .S RMPRQT=$P(RB,U,4)
 .S RMPRR=$P(RB,U,8) ;REMARKS
 .S RMPRTO=RMPRTO+$J(RMPRCT*RMPRQT,0,2)
 S RMPRTOTC=$P($G(^RMPR(664,RMPRA,4)),U,3)
 S RMPRPCD=$P(^RMPR(664,RMPRA,4),U,1),$P(^RMPR(664,RMPRA,4),U,1)=$$ENC^RMPR4LI(RMPRPCD,DUZ,RMPRA)
 S PRCA=RMPRA
 S PRCB=$P(^RMPR(664,RMPRA,4),U,6)
 S PRCC=RMPRTOTC
 S PRCSITE=$P(^RMPR(664,RMPRA,0),U,14)
 S PRCVEN=$P(^RMPR(664,RMPRA,0),U,4)
 S RMPRDFN=$P(^RMPR(664,RMPRA,0),U,2)
 S RMPRPPA=$P(^VA(200,DUZ,1),U,9)
 ; Setup Delivery to Variables
 S RMPRY(0)=$P($G(^RMPR(664,RMPRA,3)),U)
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:"")
 D DELIV^RMPR121A
 Q
C664 ;CANCEL 664 ENTRY WHEN IFCAP IS CANCELLED
 S $P(^RMPR(664,RMPRA,0),U,5)=$P(^RMPR(664,RMPRA,0),U),$P(^RMPR(664,RMPRA,2),U,2)=+DUZ
 S WDS="INSUFF FUNDS CANCEL",DA=RMPRA,DR="3.1////^S X=WDS",DIE="^RMPR(664," D ^DIE K WDS
 Q