| [613] | 1 | RMPR421 ;PHX/HNB,RVD -CREATE PURCHASE CARD TRANSACTION, POST TO 2319 ;3/1/1996
|
|---|
| 2 | ;;3.0;PROSTHETICS;**3,20,26,50,58**;Feb 09, 1996
|
|---|
| 3 | ;Per VHA Directive 10-94-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | ; ODJ - Patch 50 - 7/6/00 - NOIS NWI-0500-42828
|
|---|
| 6 | ; prompt for site if multi-divisional
|
|---|
| 7 | ;RVD - Patch 58 - 7/10/01 -add a page break when transaction is
|
|---|
| 8 | ; deleted
|
|---|
| 9 | ;
|
|---|
| 10 | I '$D(^PRC(440.5,"H",DUZ)),'$D(^PRC(440.5,"C",DUZ)) W !!,"You are not an authorized Purchase Card User, CONTACT FISCAL!" Q
|
|---|
| 11 | D DIV4^RMPRSIT Q:$D(X)
|
|---|
| 12 | I '$D(^RMPR(669.9,RMPRSITE,4)) W !!,"The IFCAP SITE has not been defined to Prosthetics yet!" Q
|
|---|
| 13 | EN1 D GETPAT^RMPRUTIL
|
|---|
| 14 | G:'$D(RMPRDFN) EXT
|
|---|
| 15 | K DIC,DINUM,DIC("DR")
|
|---|
| 16 | S X=DT,DIC("DR")="1////^S X=RMPRDFN"
|
|---|
| 17 | S DIC="^RMPR(664,",DIC(0)="AELQM",DLAYGO=664
|
|---|
| 18 | K DD,DO D FILE^DICN K DLAYGO,DIC Q:Y<0
|
|---|
| 19 | 2529 ;called from RMPR29P init from lab
|
|---|
| 20 | S (RMPRK,RMPRA)=+Y
|
|---|
| 21 | S $P(^RMPR(664,RMPRA,2),U,4)="2421PC"
|
|---|
| 22 | S DFN=RMPRDFN D DEM^VADPT
|
|---|
| 23 | VIEW ;VIEW 10-2319
|
|---|
| 24 | ;
|
|---|
| 25 | S RMPRBAC1=1 D ^RMPRPAT K RMPRBAC1 G:$D(RMPRKILL) KILL
|
|---|
| 26 | ;
|
|---|
| 27 | ;assign transaction number
|
|---|
| 28 | ;S $P(^RMPR(664,RMPRA,4),U,5)="PC"_RMPRA
|
|---|
| 29 | S DIE="^RMPR(664,",DA=RMPRA
|
|---|
| 30 | G P24^RMPR421A
|
|---|
| 31 | ;end this section
|
|---|
| 32 | ;
|
|---|
| 33 | CHK D CHK1
|
|---|
| 34 | I 'FL W !!,$C(7),?5,"REQUIRED FIELDS DO NOT EXIST ON THIS FORM",! G KILL
|
|---|
| 35 | S $P(^RMPR(664,RMPRA,0),U,9)=DUZ
|
|---|
| 36 | I $D(DTOUT)!($D(Y(0))) W !,$C(7),$C(7),"Please Try Later!" G KILL
|
|---|
| 37 | ASK ;POST TRANSACTION QUESTION
|
|---|
| 38 | S %=2 W !!,"Are you ready to POST to 10-2319 NOW"
|
|---|
| 39 | D YN^DICN G:%=1 FILE^RMPR421B G:$D(DTOUT) KILL
|
|---|
| 40 | I %=0 W !,"This will Create an Entry on the Prosthetic 10-2319 Record." G ASK
|
|---|
| 41 | DEL ;
|
|---|
| 42 | I %=-1 S %=2 R !,"Do you want to Delete this Transaction" D YN^DICN I $D(DTOUT)!(%=1) S:$D(RMPRA) RMPRK=RMPRA G KILL
|
|---|
| 43 | I %=0 W !!,"ENTER YES OR NO!!",$C(7) S %=-1 G DEL
|
|---|
| 44 | D ^RMPR4LI I RMPRX]"" G ASK
|
|---|
| 45 | L W !!!,"Enter Item to Edit: " R X:DTIME G:'$T KILL
|
|---|
| 46 | G:X["^"!(X="") ASK I X["?" D ZDSP^RMPR421A G L
|
|---|
| 47 | S DIC="^RMPR(664,"_RMPRA_",1,",DIC(0)="EQMZ" D ^DIC
|
|---|
| 48 | I +Y'>0 K DA,Y G L
|
|---|
| 49 | S DA=+Y,DA(1)=RMPRA,DIE=DIC
|
|---|
| 50 | S DR=".01;17;1;14;8;9;I $P(^RMPR(664,DA(1),1,DA,0),U,10)=4 S Y=""@1"";3;2;4;7;S Y="""";@1;10;3;2;4;7"
|
|---|
| 51 | S:RMPRDR["RMPREYE" DR=".01;8;9;I $P(^RMPR(664,DA(1),1,DA,0),U,10)=4 S Y=""@1"";1;3;2;4;7;S Y="""";@1;10;1;3;2;4;7" D ^DIE
|
|---|
| 52 | D CHK
|
|---|
| 53 | I '$D(FL) W !!,$C(7),?5,"REQUIRED FIELDS DO NOT EXIST ON THIS FORM",! G KILL
|
|---|
| 54 | S DIE="^RMPR(664,",DA=RMPRA,DR=11 D ^DIE G L
|
|---|
| 55 | ;
|
|---|
| 56 | CHK1 ;CHECK FOR EXISTENCE OF ITEMS ON PURCHASING FORMS
|
|---|
| 57 | S FL=1
|
|---|
| 58 | I $D(^RMPR(664,RMPRA,1)) S (FL,RI)=0 F S RI=$O(^RMPR(664,RMPRA,1,RI)) Q:RI'>0 Q:'$D(^(RI,0)) D
|
|---|
| 59 | .S FL=1
|
|---|
| 60 | .S RB=^RMPR(664,RMPRA,1,RI,0)
|
|---|
| 61 | .I $P(RB,U,3)=""!($P(RB,U,4)="")!($P(RB,U,5)="")!($P(RB,U,9)="")!($P(RB,U,10)="") S FL=0 Q
|
|---|
| 62 | Q
|
|---|
| 63 | ;
|
|---|
| 64 | KILL ;DELETE PURCHASING ENTRY
|
|---|
| 65 | Q:'$D(RMPRK)
|
|---|
| 66 | S DA=RMPRK,DIK="^RMPR(664," D ^DIK W !,$C(7),?20,"Deleted..." K RMPRDOD,RMPROB
|
|---|
| 67 | I $E(IOST)["C" W ! S DIR(0)="E" D ^DIR
|
|---|
| 68 | I $D(RMPRWO),$D(^RMPR(664.2,+RMPRWO,0)) D K DIK
|
|---|
| 69 | .S DA=0
|
|---|
| 70 | .F S DA=$O(^RMPR(664.2,RMPRWO,1,"AC",RMPRA,DA)) Q:$G(DA)'>0
|
|---|
| 71 | .S DIK="^RMPR(664.2,"_RMPRWO_",1,",DA(1)=RMPRWO
|
|---|
| 72 | .D ^DIK
|
|---|
| 73 | EXIT ;Common Exit Point
|
|---|
| 74 | ;ask for suspense entry to close
|
|---|
| 75 | D:'$D(DTOUT) LINK^RMPRS
|
|---|
| 76 | ;clean-up from calls to vadpt
|
|---|
| 77 | D KVAR^VADPT
|
|---|
| 78 | N RMPR,RMPRSITE,RMPRMDIV D KILL^XUSCLEAN Q
|
|---|
| 79 | ;we should be able to call kernel at this point to clean-up the rest.
|
|---|
| 80 | EXT ;K RMPRFLAG,RMPRG,RD,RMPRPSC,RMPRCONT,RMPRSH,RMPRDS,RMPRTO,RMPRCT,RMPRQT,R1,B2,D1,RMPRI,%,B1,DA,DIC,DIK,PRCS,PRCSCPAN,RMPRIN,RMPRPC,RMPRAMIS,RMPRARD,RMPRCNT,RMPRIT,RMPRIT1,RMPRU,SR,TYPE,RAC,FL,RMPRCTK,PRCSIP,PQTY,FL1,RMPRNOB,HY,RMPRGO
|
|---|
| 81 | ;K RMPRDIE,RMPRDR,RMPRDES,DIE,RMPRSR,DR,DTOUT,RMPRDOB,RMPRSC,RMPRTRN,RMPRX,RMPRK,RMPR660,RMPRA,RMPRDFN,RMPRDIS,RMPRIS,RMPRNAM,RMPRR,RMPRS,RMPRSSN
|
|---|
| 82 | ;K RMPRSSNE,RMPRT,RMPRTN,RMPRV,Y,LINE,RMPRUP,RMPRSR,RMPRPI,RI,RA,RMPRI1,RMPRDELN,RDP,Y,RMPRSER,NAME
|
|---|
| 83 | I $D(RMPRWO),RMPRWO D POST^RMPR29U Q
|
|---|
| 84 | I $D(RMPRDA) Q
|
|---|
| 85 | K RMPROB,RMPRF,PRC,PRCS,RBL,RDA,RVA,RX,RMPRKILL Q
|
|---|
