- RMPR421 ;PHX/HNB,RVD -CREATE PURCHASE CARD TRANSACTION, POST TO 2319 ;3/1/1996
- ;;3.0;PROSTHETICS;**3,20,26,50,58**;Feb 09, 1996
- ;Per VHA Directive 10-94-142, this routine should not be modified.
- ;
- ; ODJ - Patch 50 - 7/6/00 - NOIS NWI-0500-42828
- ; prompt for site if multi-divisional
- ;RVD - Patch 58 - 7/10/01 -add a page break when transaction is
- ; deleted
- ;
- 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
- D DIV4^RMPRSIT Q:$D(X)
- I '$D(^RMPR(669.9,RMPRSITE,4)) W !!,"The IFCAP SITE has not been defined to Prosthetics yet!" Q
- EN1 D GETPAT^RMPRUTIL
- G:'$D(RMPRDFN) EXT
- K DIC,DINUM,DIC("DR")
- S X=DT,DIC("DR")="1////^S X=RMPRDFN"
- S DIC="^RMPR(664,",DIC(0)="AELQM",DLAYGO=664
- K DD,DO D FILE^DICN K DLAYGO,DIC Q:Y<0
- 2529 ;called from RMPR29P init from lab
- S (RMPRK,RMPRA)=+Y
- S $P(^RMPR(664,RMPRA,2),U,4)="2421PC"
- S DFN=RMPRDFN D DEM^VADPT
- VIEW ;VIEW 10-2319
- ;
- S RMPRBAC1=1 D ^RMPRPAT K RMPRBAC1 G:$D(RMPRKILL) KILL
- ;
- ;assign transaction number
- ;S $P(^RMPR(664,RMPRA,4),U,5)="PC"_RMPRA
- S DIE="^RMPR(664,",DA=RMPRA
- G P24^RMPR421A
- ;end this section
- ;
- CHK D CHK1
- I 'FL W !!,$C(7),?5,"REQUIRED FIELDS DO NOT EXIST ON THIS FORM",! G KILL
- S $P(^RMPR(664,RMPRA,0),U,9)=DUZ
- I $D(DTOUT)!($D(Y(0))) W !,$C(7),$C(7),"Please Try Later!" G KILL
- ASK ;POST TRANSACTION QUESTION
- S %=2 W !!,"Are you ready to POST to 10-2319 NOW"
- D YN^DICN G:%=1 FILE^RMPR421B G:$D(DTOUT) KILL
- I %=0 W !,"This will Create an Entry on the Prosthetic 10-2319 Record." G ASK
- DEL ;
- 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
- I %=0 W !!,"ENTER YES OR NO!!",$C(7) S %=-1 G DEL
- D ^RMPR4LI I RMPRX]"" G ASK
- L W !!!,"Enter Item to Edit: " R X:DTIME G:'$T KILL
- G:X["^"!(X="") ASK I X["?" D ZDSP^RMPR421A G L
- S DIC="^RMPR(664,"_RMPRA_",1,",DIC(0)="EQMZ" D ^DIC
- I +Y'>0 K DA,Y G L
- S DA=+Y,DA(1)=RMPRA,DIE=DIC
- 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"
- 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
- D CHK
- I '$D(FL) W !!,$C(7),?5,"REQUIRED FIELDS DO NOT EXIST ON THIS FORM",! G KILL
- S DIE="^RMPR(664,",DA=RMPRA,DR=11 D ^DIE G L
- ;
- CHK1 ;CHECK FOR EXISTENCE OF ITEMS ON PURCHASING FORMS
- S FL=1
- 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
- .S FL=1
- .S RB=^RMPR(664,RMPRA,1,RI,0)
- .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
- Q
- ;
- KILL ;DELETE PURCHASING ENTRY
- Q:'$D(RMPRK)
- S DA=RMPRK,DIK="^RMPR(664," D ^DIK W !,$C(7),?20,"Deleted..." K RMPRDOD,RMPROB
- I $E(IOST)["C" W ! S DIR(0)="E" D ^DIR
- I $D(RMPRWO),$D(^RMPR(664.2,+RMPRWO,0)) D K DIK
- .S DA=0
- .F S DA=$O(^RMPR(664.2,RMPRWO,1,"AC",RMPRA,DA)) Q:$G(DA)'>0
- .S DIK="^RMPR(664.2,"_RMPRWO_",1,",DA(1)=RMPRWO
- .D ^DIK
- EXIT ;Common Exit Point
- ;ask for suspense entry to close
- D:'$D(DTOUT) LINK^RMPRS
- ;clean-up from calls to vadpt
- D KVAR^VADPT
- N RMPR,RMPRSITE,RMPRMDIV D KILL^XUSCLEAN Q
- ;we should be able to call kernel at this point to clean-up the rest.
- 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
- ;K RMPRDIE,RMPRDR,RMPRDES,DIE,RMPRSR,DR,DTOUT,RMPRDOB,RMPRSC,RMPRTRN,RMPRX,RMPRK,RMPR660,RMPRA,RMPRDFN,RMPRDIS,RMPRIS,RMPRNAM,RMPRR,RMPRS,RMPRSSN
- ;K RMPRSSNE,RMPRT,RMPRTN,RMPRV,Y,LINE,RMPRUP,RMPRSR,RMPRPI,RI,RA,RMPRI1,RMPRDELN,RDP,Y,RMPRSER,NAME
- I $D(RMPRWO),RMPRWO D POST^RMPR29U Q
- I $D(RMPRDA) Q
- K RMPROB,RMPRF,PRC,PRCS,RBL,RDA,RVA,RX,RMPRKILL Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR421 3923 printed Feb 18, 2025@23:59:05 Page 2
- RMPR421 ;PHX/HNB,RVD -CREATE PURCHASE CARD TRANSACTION, POST TO 2319 ;3/1/1996
- +1 ;;3.0;PROSTHETICS;**3,20,26,50,58**;Feb 09, 1996
- +2 ;Per VHA Directive 10-94-142, this routine should not be modified.
- +3 ;
- +4 ; ODJ - Patch 50 - 7/6/00 - NOIS NWI-0500-42828
- +5 ; prompt for site if multi-divisional
- +6 ;RVD - Patch 58 - 7/10/01 -add a page break when transaction is
- +7 ; deleted
- +8 ;
- +9 IF '$DATA(^PRC(440.5,"H",DUZ))
- IF '$DATA(^PRC(440.5,"C",DUZ))
- WRITE !!,"You are not an authorized Purchase Card User, CONTACT FISCAL!"
- QUIT
- +10 DO DIV4^RMPRSIT
- if $DATA(X)
- QUIT
- +11 IF '$DATA(^RMPR(669.9,RMPRSITE,4))
- WRITE !!,"The IFCAP SITE has not been defined to Prosthetics yet!"
- QUIT
- EN1 DO GETPAT^RMPRUTIL
- +1 if '$DATA(RMPRDFN)
- GOTO EXT
- +2 KILL DIC,DINUM,DIC("DR")
- +3 SET X=DT
- SET DIC("DR")="1////^S X=RMPRDFN"
- +4 SET DIC="^RMPR(664,"
- SET DIC(0)="AELQM"
- SET DLAYGO=664
- +5 KILL DD,DO
- DO FILE^DICN
- KILL DLAYGO,DIC
- if Y<0
- QUIT
- 2529 ;called from RMPR29P init from lab
- +1 SET (RMPRK,RMPRA)=+Y
- +2 SET $PIECE(^RMPR(664,RMPRA,2),U,4)="2421PC"
- +3 SET DFN=RMPRDFN
- DO DEM^VADPT
- VIEW ;VIEW 10-2319
- +1 ;
- +2 SET RMPRBAC1=1
- DO ^RMPRPAT
- KILL RMPRBAC1
- if $DATA(RMPRKILL)
- GOTO KILL
- +3 ;
- +4 ;assign transaction number
- +5 ;S $P(^RMPR(664,RMPRA,4),U,5)="PC"_RMPRA
- +6 SET DIE="^RMPR(664,"
- SET DA=RMPRA
- +7 GOTO P24^RMPR421A
- +8 ;end this section
- +9 ;
- CHK DO CHK1
- +1 IF 'FL
- WRITE !!,$CHAR(7),?5,"REQUIRED FIELDS DO NOT EXIST ON THIS FORM",!
- GOTO KILL
- +2 SET $PIECE(^RMPR(664,RMPRA,0),U,9)=DUZ
- +3 IF $DATA(DTOUT)!($DATA(Y(0)))
- WRITE !,$CHAR(7),$CHAR(7),"Please Try Later!"
- GOTO KILL
- ASK ;POST TRANSACTION QUESTION
- +1 SET %=2
- WRITE !!,"Are you ready to POST to 10-2319 NOW"
- +2 DO YN^DICN
- if %=1
- GOTO FILE^RMPR421B
- if $DATA(DTOUT)
- GOTO KILL
- +3 IF %=0
- WRITE !,"This will Create an Entry on the Prosthetic 10-2319 Record."
- GOTO ASK
- DEL ;
- +1 IF %=-1
- SET %=2
- READ !,"Do you want to Delete this Transaction"
- DO YN^DICN
- IF $DATA(DTOUT)!(%=1)
- if $DATA(RMPRA)
- SET RMPRK=RMPRA
- GOTO KILL
- +2 IF %=0
- WRITE !!,"ENTER YES OR NO!!",$CHAR(7)
- SET %=-1
- GOTO DEL
- +3 DO ^RMPR4LI
- IF RMPRX]""
- GOTO ASK
- L WRITE !!!,"Enter Item to Edit: "
- READ X:DTIME
- if '$TEST
- GOTO KILL
- +1 if X["^"!(X="")
- GOTO ASK
- IF X["?"
- DO ZDSP^RMPR421A
- GOTO L
- +2 SET DIC="^RMPR(664,"_RMPRA_",1,"
- SET DIC(0)="EQMZ"
- DO ^DIC
- +3 IF +Y'>0
- KILL DA,Y
- GOTO L
- +4 SET DA=+Y
- SET DA(1)=RMPRA
- SET DIE=DIC
- +5 SET 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"
- +6 if RMPRDR["RMPREYE"
- SET 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"
- DO ^DIE
- +7 DO CHK
- +8 IF '$DATA(FL)
- WRITE !!,$CHAR(7),?5,"REQUIRED FIELDS DO NOT EXIST ON THIS FORM",!
- GOTO KILL
- +9 SET DIE="^RMPR(664,"
- SET DA=RMPRA
- SET DR=11
- DO ^DIE
- GOTO L
- +10 ;
- CHK1 ;CHECK FOR EXISTENCE OF ITEMS ON PURCHASING FORMS
- +1 SET FL=1
- +2 IF $DATA(^RMPR(664,RMPRA,1))
- SET (FL,RI)=0
- FOR
- SET RI=$ORDER(^RMPR(664,RMPRA,1,RI))
- if RI'>0
- QUIT
- if '$DATA(^(RI,0))
- QUIT
- Begin DoDot:1
- +3 SET FL=1
- +4 SET RB=^RMPR(664,RMPRA,1,RI,0)
- +5 IF $PIECE(RB,U,3)=""!($PIECE(RB,U,4)="")!($PIECE(RB,U,5)="")!($PIECE(RB,U,9)="")!($PIECE(RB,U,10)="")
- SET FL=0
- QUIT
- End DoDot:1
- +6 QUIT
- +7 ;
- KILL ;DELETE PURCHASING ENTRY
- +1 if '$DATA(RMPRK)
- QUIT
- +2 SET DA=RMPRK
- SET DIK="^RMPR(664,"
- DO ^DIK
- WRITE !,$CHAR(7),?20,"Deleted..."
- KILL RMPRDOD,RMPROB
- +3 IF $EXTRACT(IOST)["C"
- WRITE !
- SET DIR(0)="E"
- DO ^DIR
- +4 IF $DATA(RMPRWO)
- IF $DATA(^RMPR(664.2,+RMPRWO,0))
- Begin DoDot:1
- +5 SET DA=0
- +6 FOR
- SET DA=$ORDER(^RMPR(664.2,RMPRWO,1,"AC",RMPRA,DA))
- if $GET(DA)'>0
- QUIT
- +7 SET DIK="^RMPR(664.2,"_RMPRWO_",1,"
- SET DA(1)=RMPRWO
- +8 DO ^DIK
- End DoDot:1
- KILL DIK
- EXIT ;Common Exit Point
- +1 ;ask for suspense entry to close
- +2 if '$DATA(DTOUT)
- DO LINK^RMPRS
- +3 ;clean-up from calls to vadpt
- +4 DO KVAR^VADPT
- +5 NEW RMPR,RMPRSITE,RMPRMDIV
- DO KILL^XUSCLEAN
- QUIT
- +6 ;we should be able to call kernel at this point to clean-up the rest.
- 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
- +1 ;K RMPRDIE,RMPRDR,RMPRDES,DIE,RMPRSR,DR,DTOUT,RMPRDOB,RMPRSC,RMPRTRN,RMPRX,RMPRK,RMPR660,RMPRA,RMPRDFN,RMPRDIS,RMPRIS,RMPRNAM,RMPRR,RMPRS,RMPRSSN
- +2 ;K RMPRSSNE,RMPRT,RMPRTN,RMPRV,Y,LINE,RMPRUP,RMPRSR,RMPRPI,RI,RA,RMPRI1,RMPRDELN,RDP,Y,RMPRSER,NAME
- +3 IF $DATA(RMPRWO)
- IF RMPRWO
- DO POST^RMPR29U
- QUIT
- +4 IF $DATA(RMPRDA)
- QUIT
- +5 KILL RMPROB,RMPRF,PRC,PRCS,RBL,RDA,RVA,RX,RMPRKILL
- QUIT