RMPR121B ;PHX/HNC -POST GUI PURCHASE ORDER TRANSACTION ;3/1/2003
;;3.0;PROSTHETICS;**90,75,137,147,151,153**;FEB 09,1996;Build 10
;Per VHA Directive 2004-038, 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
D UP1^PRCH7PUC(.X,PRCA,PRCB,PRCC,PRCSITE,PRCVEN,PRCRMPR)
I X="^"!(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 RMPRPCD=$P(^RMPR(664,RMPRA,4),U,1),$P(^RMPR(664,RMPRA,4),U,1)=$$ENC^RMPR4LI(RMPRPCD,DUZ,RMPRA)
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 S RMPRPRIV=1 D ^RMPR4P21
I +RMPRPTR>0 S RMPRPRIV=1 D EN1^RMPR4P21(RMPRPTR)
K RMPRPRIV
Q
QUIT ; Quit where IFCAP encountered a problem
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"
S:XBAD="#" RESULT="1^Your IFCAP order has been cancelled due to reaching the max seq for the Fund Control Point Activity requisition."
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 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 XBAD=X
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" S:XBAD="#" WDS="Max FCP req seq reached"
S DA=RMPRA,DR="3.1////^S X=WDS",DIE="^RMPR(664," D ^DIE K WDS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR121B 4114 printed Dec 13, 2024@02:31:42 Page 2
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
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
A1(SIG,RMPRA,RMPRSITE) SET RMPRGUI=1
GOTO A2
GUI(RESULT,SIG,RMPRA,RMPRSITE,RMPRPTR) ;
A2 IF (SIG="")!($EXTRACT(SIG)="^")
SET RESULT=1_"^"_"Not Valid, Try Again..."
QUIT
+1 KILL RESULT
DO SIGN
+2 QUIT
+3 ;
SIGN ; Validate /es/-code
+1 ;
+2 SET X=SIG
+3 SET RMPRY=0
+4 DO HASH^XUSHSHP
IF X]""
IF (X=$PIECE($GET(^VA(200,+DUZ,20)),U,4))
SET RMPRY=1
+5 IF RMPRY=0
SET RESULT=1_"^"_"Checked signature Not Valid, Try Again..."
QUIT
+6 ;
+7 SET RMPRV=$PIECE(^RMPR(664,RMPRA,0),U,4)
+8 SET RMPRPER=$PIECE(^RMPR(664,RMPRA,2),U,6)/100
+9 DO GUIVAR
+10 SET PRCRMPR=1
SET X=1
+11 DO UP1^PRCH7PUC(.X,PRCA,PRCB,PRCC,PRCSITE,PRCVEN,PRCRMPR)
+12 IF X="^"!(X="#")
DO C664
GOTO QUIT
+13 SET PRC442=$PIECE(^RMPR(664,RMPRA,4),U,6)
+14 IF $PIECE(^PRC(442,PRC442,7),U,1)'=6
GOTO QUT
+15 SET $PIECE(^RMPR(664,RMPRA,0),U,5)=""
SET $PIECE(^RMPR(664,RMPRA,2),U)=""
SET $PIECE(^RMPR(664,RMPRA,2),U,2)=""
+16 IF $DATA(RMPRPSC)
SET $PIECE(^RMPR(664,RMPRA,2),U,5)=RMPRPSC
+17 SET RMPRPCD=$PIECE(^RMPR(664,RMPRA,4),U,1)
SET $PIECE(^RMPR(664,RMPRA,4),U,1)=$$ENC^RMPR4LI(RMPRPCD,DUZ,RMPRA)
+18 SET DA=RMPRA
SET DIK="^RMPR(664,"
DO IX1^DIK
+19 ;get AMIS grouper number
+20 LOCK +^RMPR(669.9,RMPRSITE,0):999
IF $TEST=0
SET RMPRG=DT_99
GOTO GGC
+21 SET RMPRG=$PIECE(^RMPR(669.9,RMPRSITE,0),U,7)
SET RMPRG=RMPRG-1
SET $PIECE(^(0),U,7)=RMPRG
LOCK -^RMPR(669.9,RMPRSITE,0)
+22 ;
GGC SET B2=0
+1 FOR
SET B2=$ORDER(^RMPR(664,RMPRA,1,B2))
if B2'>0
QUIT
DO R19^RMPR121C
+2 KILL RMPRDP
+3 ; Shipping Record
+4 IF +RMPRSH'>0
GOTO NS
+5 KILL DD,DO
SET X=DT
SET DIC="^RMPR(660,"
SET DIC(0)="LZ"
DO FILE^DICN
KILL DIC,D0
SET (RMPR660,DA)=+Y
+6 SET RMPRTRN=$PIECE(^RMPR(664,RMPRA,4),U,5)
+7 SET $PIECE(^RMPR(660,RMPR660,4),U,3)=RMPRV
+8 SET ^RMPR(660,RMPR660,0)=DT_U_RMPRDFN_U_DT_"^X^^^^^"_U_RMPR("STA")_"^^^14"_U_RMPRS_"^^"_RMPRSH_"^"_RMPRSH_"^^^^^"
SET ^("AMS")=RMPRG
SET ^("AM")=U_U_RMPRDIS_U_RMPRSC
SET $PIECE(^(0),U,27)=DUZ
+9 ; /SPS Removed the following 2 lines for 75 may re-use at a later time
+10 ; I $D(RMPRWO),RMPRWO S $P(^("AM"),U,2)=1 D
+11 ;.I $D(^RMPR(664.2,RMPRWO,0)) S $P(^(0),U,6)=$P(^(0),U,6)+RMPRSH
+12 if $DATA(RMPRDELN)
SET ^RMPR(660,RMPR660,3)=RMPRDELN
SET ^(1)=RMPRTRN
+13 SET DIK="^RMPR(660,"
DO IX1^DIK
SET $PIECE(^RMPR(664,RMPRA,0),U,12)=RMPR660
KILL RMPRDP
NS SET $PIECE(^RMPR(664,RMPRA,2),U,4)="2421PC"
+1 SET RESULT=0_"^"_"PO COMPLETE"
+2 SET ^TMP("SPS",0)=RMPRPTR
+3 IF RMPRPTR=0
SET RMPRPRIV=1
DO ^RMPR4P21
+4 IF +RMPRPTR>0
SET RMPRPRIV=1
DO EN1^RMPR4P21(RMPRPTR)
+5 KILL RMPRPRIV
+6 QUIT
QUIT ; Quit where IFCAP encountered a problem
+1 if XBAD="^"
SET 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"
+2 if XBAD="#"
SET RESULT="1^Your IFCAP order has been cancelled due to reaching the max seq for the Fund Control Point Activity requisition."
+3 QUIT
QUT ;
+1 SET RESULT="1^IFCAP did not update your Purchase Order, Please Log out and start over."
+2 QUIT
GUIVAR ; Get variable setup from the GUI application
+1 ; Setup Site Variables
+2 DO INF^RMPRSIT
+3 ; Shipping info
+4 SET $PIECE(^RMPR(664,RMPRA,0),U,14)=RMPR("STA")
+5 SET (R1,RMPRCT,RMPRQT,RMPRTO,RMPRI,RMPRR)=0
+6 SET RMPRSH=$SELECT($PIECE(^RMPR(664,RMPRA,0),U,10):$PIECE(^(0),U,10),1:"")
+7 FOR
SET R1=$ORDER(^RMPR(664,RMPRA,1,R1))
if R1'>0
QUIT
Begin DoDot:1
+8 SET RB=^RMPR(664,RMPRA,1,R1,0)
+9 SET RMPRCT=$PIECE(RB,U,3)
+10 SET RMPRQT=$PIECE(RB,U,4)
+11 ;REMARKS
SET RMPRR=$PIECE(RB,U,8)
+12 SET RMPRTO=RMPRTO+$JUSTIFY(RMPRCT*RMPRQT,0,2)
End DoDot:1
+13 SET RMPRTOTC=$PIECE($GET(^RMPR(664,RMPRA,4)),U,3)
+14 SET PRCA=RMPRA
+15 SET PRCB=$PIECE(^RMPR(664,RMPRA,4),U,6)
+16 SET PRCC=RMPRTOTC
+17 SET PRCSITE=$PIECE(^RMPR(664,RMPRA,0),U,14)
+18 SET PRCVEN=$PIECE(^RMPR(664,RMPRA,0),U,4)
+19 SET RMPRDFN=$PIECE(^RMPR(664,RMPRA,0),U,2)
+20 SET RMPRPPA=$PIECE(^VA(200,DUZ,1),U,9)
+21 ; Setup Delivery to Variables
+22 SET RMPRY(0)=$PIECE($GET(^RMPR(664,RMPRA,3)),U)
TST SET RMPRY=$SELECT(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 DO DELIV^RMPR121A
+2 QUIT
C664 ;CANCEL 664 ENTRY WHEN IFCAP IS CANCELLED
+1 SET XBAD=X
+2 SET $PIECE(^RMPR(664,RMPRA,0),U,5)=$PIECE(^RMPR(664,RMPRA,0),U)
SET $PIECE(^RMPR(664,RMPRA,2),U,2)=+DUZ
+3 SET WDS="INSUFF FUNDS CANCEL"
if XBAD="#"
SET WDS="Max FCP req seq reached"
+4 SET DA=RMPRA
SET DR="3.1////^S X=WDS"
SET DIE="^RMPR(664,"
DO ^DIE
KILL WDS
+5 QUIT
