- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR121B.m
r613 r623 1 RMPR121B ;PHX/HNC -POST GUI PURCHASE ORDER TRANSACTION ;3/1/2003 2 ;;3.0;PROSTHETICS;**90,75,137**;FEB 09,1996;Build 5 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 A1(SIG,RMPRA,RMPRSITE) S RMPRGUI=1 G A2 5 GUI(RESULT,SIG,RMPRA,RMPRSITE,RMPRPTR) ; 6 A2 I (SIG="")!($E(SIG)="^") S RESULT=1_"^"_"Not Valid, Try Again..." Q 7 K RESULT D SIGN 8 Q 9 ; 10 SIGN ; Validate /es/-code 11 ; 12 S X=SIG 13 S RMPRY=0 14 D HASH^XUSHSHP I X]"",(X=$P($G(^VA(200,+DUZ,20)),U,4)) S RMPRY=1 15 I RMPRY=0 S RESULT=1_"^"_"Checked signature Not Valid, Try Again..." Q 16 ; 17 S RMPRV=$P(^RMPR(664,RMPRA,0),U,4) 18 S RMPRPER=$P(^RMPR(664,RMPRA,2),U,6)/100 19 D GUIVAR 20 S PRCRMPR=1,X=1,PRCRMPR=1 21 D UP1^PRCH7PUC(.X,PRCA,PRCB,PRCC,PRCSITE,PRCVEN,PRCRMPR) 22 I X="^" D C664 G QUIT 23 S PRC442=$P(^RMPR(664,RMPRA,4),U,6) 24 I $P(^PRC(442,PRC442,7),U,1)'=6 G QUT 25 S $P(^RMPR(664,RMPRA,0),U,5)="",$P(^RMPR(664,RMPRA,2),U)="",$P(^RMPR(664,RMPRA,2),U,2)="" 26 I $D(RMPRPSC) S $P(^RMPR(664,RMPRA,2),U,5)=RMPRPSC 27 S DA=RMPRA,DIK="^RMPR(664," D IX1^DIK 28 ;get AMIS grouper number 29 L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G GGC 30 S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1,$P(^(0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0) 31 ; 32 GGC S B2=0 33 F S B2=$O(^RMPR(664,RMPRA,1,B2)) Q:B2'>0 D R19^RMPR121C 34 K RMPRDP 35 ; Shipping Record 36 I +RMPRSH'>0 G NS 37 K DD,DO S X=DT,DIC="^RMPR(660,",DIC(0)="LZ" D FILE^DICN K DIC,D0 S (RMPR660,DA)=+Y 38 S RMPRTRN=$P(^RMPR(664,RMPRA,4),U,5) 39 S $P(^RMPR(660,RMPR660,4),U,3)=RMPRV 40 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 41 ; /SPS Removed the following 2 lines for 75 may re-use at a later time 42 ; I $D(RMPRWO),RMPRWO S $P(^("AM"),U,2)=1 D 43 ;.I $D(^RMPR(664.2,RMPRWO,0)) S $P(^(0),U,6)=$P(^(0),U,6)+RMPRSH 44 S:$D(RMPRDELN) ^RMPR(660,RMPR660,3)=RMPRDELN S ^(1)=RMPRTRN 45 S DIK="^RMPR(660," D IX1^DIK S $P(^RMPR(664,RMPRA,0),U,12)=RMPR660 K RMPRDP 46 NS S $P(^RMPR(664,RMPRA,2),U,4)="2421PC" 47 S RESULT=0_"^"_"PO COMPLETE" 48 S ^TMP("SPS",0)=RMPRPTR 49 I RMPRPTR=0 D ^RMPR4P21 50 I +RMPRPTR>0 D EN1^RMPR4P21(RMPRPTR) 51 Q 52 QUIT ; Quit where IFCAP encountered a problem 53 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" 54 Q 55 QUT ; 56 S RESULT="1^IFCAP did not update your Purchase Order, Please Log out and start over." 57 Q 58 GUIVAR ; Get variable setup from the GUI application 59 ; Setup Site Variables 60 D INF^RMPRSIT 61 ; Shipping info 62 S $P(^RMPR(664,RMPRA,0),U,14)=RMPR("STA") 63 S (R1,RMPRCT,RMPRQT,RMPRTO,RMPRI,RMPRR)=0 64 S RMPRSH=$S($P(^RMPR(664,RMPRA,0),U,10):$P(^(0),U,10),1:"") 65 F S R1=$O(^RMPR(664,RMPRA,1,R1)) Q:R1'>0 D 66 .S RB=^RMPR(664,RMPRA,1,R1,0) 67 .S RMPRCT=$P(RB,U,3) 68 .S RMPRQT=$P(RB,U,4) 69 .S RMPRR=$P(RB,U,8) ;REMARKS 70 .S RMPRTO=RMPRTO+$J(RMPRCT*RMPRQT,0,2) 71 S RMPRTOTC=$P($G(^RMPR(664,RMPRA,4)),U,3) 72 S RMPRPCD=$P(^RMPR(664,RMPRA,4),U,1),$P(^RMPR(664,RMPRA,4),U,1)=$$ENC^RMPR4LI(RMPRPCD,DUZ,RMPRA) 73 S PRCA=RMPRA 74 S PRCB=$P(^RMPR(664,RMPRA,4),U,6) 75 S PRCC=RMPRTOTC 76 S PRCSITE=$P(^RMPR(664,RMPRA,0),U,14) 77 S PRCVEN=$P(^RMPR(664,RMPRA,0),U,4) 78 S RMPRDFN=$P(^RMPR(664,RMPRA,0),U,2) 79 S RMPRPPA=$P(^VA(200,DUZ,1),U,9) 80 ; Setup Delivery to Variables 81 S RMPRY(0)=$P($G(^RMPR(664,RMPRA,3)),U) 82 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:"") 83 D DELIV^RMPR121A 84 Q 85 C664 ;CANCEL 664 ENTRY WHEN IFCAP IS CANCELLED 86 S $P(^RMPR(664,RMPRA,0),U,5)=$P(^RMPR(664,RMPRA,0),U),$P(^RMPR(664,RMPRA,2),U,2)=+DUZ 87 S WDS="INSUFF FUNDS CANCEL",DA=RMPRA,DR="3.1////^S X=WDS",DIE="^RMPR(664," D ^DIE K WDS 88 Q 1 RMPR121B ;PHX/HNC -POST GUI PURCHASE ORDER TRANSACTION ;3/1/2003 2 ;;3.0;PROSTHETICS;**90,75**;FEB 09,1996;Build 25 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 A1(SIG,RMPRA,RMPRSITE) S RMPRGUI=1 G A2 5 GUI(RESULT,SIG,RMPRA,RMPRSITE,RMPRPTR) ; 6 A2 I (SIG="")!($E(SIG)="^") S RESULT=1_"^"_"Not Valid, Try Again..." Q 7 K RESULT D SIGN 8 Q 9 ; 10 SIGN ; Validate /es/-code 11 ; 12 S X=SIG 13 S RMPRY=0 14 D HASH^XUSHSHP I X]"",(X=$P($G(^VA(200,+DUZ,20)),U,4)) S RMPRY=1 15 I RMPRY=0 S RESULT=1_"^"_"Checked signature Not Valid, Try Again..." Q 16 ; 17 S RMPRV=$P(^RMPR(664,RMPRA,0),U,4) 18 S RMPRPER=$P(^RMPR(664,RMPRA,2),U,6)/100 19 D GUIVAR 20 S PRCRMPR=1,X=1,PRCRMPR=1 21 D UP1^PRCH7PUC(.X,PRCA,PRCB,PRCC,PRCSITE,PRCVEN,PRCRMPR) 22 I X="^" G QUIT 23 S PRC442=$P(^RMPR(664,RMPRA,4),U,6) 24 I $P(^PRC(442,PRC442,7),U,1)'=6 G QUT 25 I $D(RMPRPSC) S $P(^RMPR(664,RMPRA,2),U,5)=RMPRPSC 26 S DA=RMPRA,DIK="^RMPR(664," D IX1^DIK 27 ;get AMIS grouper number 28 L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G GGC 29 S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1,$P(^(0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0) 30 ; 31 GGC S B2=0 32 F S B2=$O(^RMPR(664,RMPRA,1,B2)) Q:B2'>0 D R19^RMPR121C 33 K RMPRDP 34 ; Shipping Record 35 I +RMPRSH'>0 G NS 36 K DD,DO S X=DT,DIC="^RMPR(660,",DIC(0)="LZ" D FILE^DICN K DIC,D0 S (RMPR660,DA)=+Y 37 S RMPRTRN=$P(^RMPR(664,RMPRA,4),U,5) 38 S $P(^RMPR(660,RMPR660,4),U,3)=RMPRV 39 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 40 ; /SPS Removed the following 2 lines for 75 may re-use at a later time 41 ; I $D(RMPRWO),RMPRWO S $P(^("AM"),U,2)=1 D 42 ;.I $D(^RMPR(664.2,RMPRWO,0)) S $P(^(0),U,6)=$P(^(0),U,6)+RMPRSH 43 S:$D(RMPRDELN) ^RMPR(660,RMPR660,3)=RMPRDELN S ^(1)=RMPRTRN 44 S DIK="^RMPR(660," D IX1^DIK S $P(^RMPR(664,RMPRA,0),U,12)=RMPR660 K RMPRDP 45 NS S $P(^RMPR(664,RMPRA,2),U,4)="2421PC" 46 S RESULT=0_"^"_"PO COMPLETE" 47 S ^TMP("SPS",0)=RMPRPTR 48 I RMPRPTR=0 D ^RMPR4P21 49 I +RMPRPTR>0 D EN1^RMPR4P21(RMPRPTR) 50 Q 51 QUIT ; Quit where IFCAP encountered a problem 52 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" 53 Q 54 QUT ; 55 S RESULT="1^IFCAP did not update your Purchase Order, Please Log out and start over." 56 Q 57 GUIVAR ; Get variable setup from the GUI application 58 ; Setup Site Variables 59 D INF^RMPRSIT 60 ; Shipping info 61 S $P(^RMPR(664,RMPRA,0),U,14)=RMPR("STA") 62 S (R1,RMPRCT,RMPRQT,RMPRTO,RMPRI,RMPRR)=0 63 S RMPRSH=$S($P(^RMPR(664,RMPRA,0),U,10):$P(^(0),U,10),1:"") 64 F S R1=$O(^RMPR(664,RMPRA,1,R1)) Q:R1'>0 D 65 .S RB=^RMPR(664,RMPRA,1,R1,0) 66 .S RMPRCT=$P(RB,U,3) 67 .S RMPRQT=$P(RB,U,4) 68 .S RMPRR=$P(RB,U,8) ;REMARKS 69 .S RMPRTO=RMPRTO+$J(RMPRCT*RMPRQT,0,2) 70 S RMPRTOTC=$P($G(^RMPR(664,RMPRA,4)),U,3) 71 S RMPRPCD=$P(^RMPR(664,RMPRA,4),U,1),$P(^RMPR(664,RMPRA,4),U,1)=$$ENC^RMPR4LI(RMPRPCD,DUZ,RMPRA) 72 S PRCA=RMPRA 73 S PRCB=$P(^RMPR(664,RMPRA,4),U,6) 74 S PRCC=RMPRTOTC 75 S PRCSITE=$P(^RMPR(664,RMPRA,0),U,14) 76 S PRCVEN=$P(^RMPR(664,RMPRA,0),U,4) 77 S RMPRDFN=$P(^RMPR(664,RMPRA,0),U,2) 78 S RMPRPPA=$P(^VA(200,DUZ,1),U,9) 79 ; Setup Delivery to Variables 80 S RMPRY(0)=$P($G(^RMPR(664,RMPRA,3)),U) 81 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:"") 82 D DELIV^RMPR121A 83 Q
Note:
See TracChangeset
for help on using the changeset viewer.
