source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR421A.m@ 896

Last change on this file since 896 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.1 KB
Line 
1RMPR421A ;PHX/HNB -CONT. CREATE PURCHASE CARD TRANSACTION ;3/1/1996
2 ;;3.0;PROSTHETICS;**3,20,22,41,50**;Feb 09, 1996
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4P24 ;DATE REQUIRED
5 ;die array set in rmpr421
6 ;
7 K %DT
8 S DR="20//T+30" D ^DIE I $D(DTOUT)!($D(Y)'=0) G KILL^RMPR421
9 ;
10COT ;CONTRACT AUTHORITY
11 I '$D(^RMPR(664,RMPRA,3)) S ^(3)=""
12 S DR="4"
13COT1 D ^DIE I $D(DTOUT)!($D(Y)'=0) G KILL^RMPR421
14 S RMPRV=$P($G(^RMPR(664,RMPRA,0)),U,4)
15 I $D(^PRC(440,RMPRV,4)) D VCON
16 I $G(RMPRV)="" W !!,"Can Not Continue without a Vendor!" G KILL^RMPR421
17IFCAP ;call PRCH7B here
18 ;pass station number external 3 dig number, and vendor ien to 440
19 ;return PRCA as ien to 442^po number (no station) ^16 dig number
20 S PRCA=$P(^RMPR(669.9,RMPRSITE,4),U,1)_U_RMPRV
21 D ADD^PRCH7B(.PRCA)
22 I PRCA="^" K PRCA S RMPRK=RMPRA G KILL^RMPR421
23 ;scramble and set 16 dig purchase card number
24 S $P(^RMPR(664,RMPRA,4),U,1)=$$ENC^RMPR4LI($P(PRCA,U,3),DUZ,RMPRA)
25 ;set the transaction number the same as ifcap
26 S $P(^RMPR(664,RMPRA,4),U,5)=$P(PRCA,U,2)
27 ;set the pointer to file 442
28 S $P(^RMPR(664,RMPRA,4),U,6)=$P(PRCA,U,1)
29 K PRCA
30 ;
31L2 ;edit
32 W !,"------------------------------",!
33TRAN K DIR S DIR(0)="SMAO^I:INITIAL ISSUE;R:REPLACE;S:SPARE;X:REPAIR"
34 S DIR("A")="TYPE OF TRANSACTION: " D ^DIR
35 ;I $D(DUOUT)!$D(DTOUT) G:$G(RMCLOF)!($G(REDIT)) CHK
36 I $D(DUOUT)!$D(DTOUT) G CHK
37 I (Y="")&($D(^RMPR(664,RMPRA,1))) G CHK
38 I (Y="")&('$D(^RMPR(664,RMPRA,1))) W !,"Please enter type of Transaction!!" G TRAN
39 S RMTYPE=Y
40PCAT K DIR S DIR(0)="SMAO^1:SC/OP;2:SC/IP;3:NSC/IP;4:NSC/OP"
41 S DIR("A")="PATIENT CATEGORY: " D ^DIR
42 I $D(DUOUT)!$D(DTOUT) G CHK
43 I (Y="")&($D(^RMPR(664,RMPRA,1))) G CHK
44 I (Y="")&('$D(^RMPR(664,RMPRA,1))) W !,"Please enter Patient Category!!" G PCAT
45 S RMCAT=Y K DIR G:RMCAT<4 ITEM
46SPES S DIR(0)="SMAO^1:SPECIAL LEGISLATION;2:A&A;3:PHC;4:ELIGIBILITY REFORM"
47 S DIR("A")="SPECIAL CATEGORY: "
48 I RMCAT=4 D ^DIR I $D(DUOUT)!$D(DTOUT) G CHK
49 I RMCAT=4 S RMSPE=Y
50 K DIR
51ITEM ;
52 K DIR S DIR(0)="FO",DIR("A")="Select ITEM"
53 S DIR("?")="^S RFL=1 D ZDSP^RMPR421A"
54 D ^DIR G:$D(DTOUT) KILL^RMPR421 G:$D(DUOUT) CHK
55 G:$D(DIRUT)&($D(^RMPR(664,RMPRA,1))) CHK
56 S DIC=661,DIC(0)="EQMZ" D ^DIC G:+Y'>0 ITEM
57 D EDT^RMPR4UTL G:$D(DTOUT) KILL^RMPR421 G L2
58CHK K RFL S FL=1
59 I '$D(^RMPR(664,RMPRA,1)) W !!,?5,$C(7),"REQUIRED FIELDS DO NOT EXIST ON THIS FORM",! G KILL^RMPR421
60 I $D(^RMPR(664,RMPRA,1)) S FL=0 F RI=0:0 S RI=$O(^RMPR(664,RMPRA,1,RI)) Q:RI'>0 I $D(^(RI,0)) S FL=1 I $P(^(0),U,3)=""!($P(^(0),U,4)="")!($P(^(0),U,5)="")!($P(^(0),U,9)="")!($P(^(0),U,10)="") S FL=0 Q
61 I 'FL W !!,?5,$C(7),"REQUIRED FIELDS DO NOT EXIST ON THIS FORM",! G KILL^RMPR421
62 S $P(^RMPR(664,RMPRA,0),U,9)=DUZ
63 I $D(DUOUT)&('$D(^RMPR(664,RMPRA,1))) W !,$C(7),$C(7),"Please Try Later!" G KILL^RMPR421
64 S DA=RMPRA,DIE=664,DR="11;17;26" D ^DIE
65ASK ;deliver to
66 K DIR
67 S DIR(0)="SAO^1:VETERAN;2:VAMC WAREHOUSE;3:PROSTHETICS;4:OTHER;"
68 S DIR("A")="DELIVER TO: "
69 D ^DIR K DIR G:$D(DTOUT) KILL^RMPR421
70 I $D(DIRUT)!(X="") W $C(7),"Delivery is required. Enter '?' for additional help." G ASK
71 ;deliver to other
72 S:Y'=4 RMPRDELN=Y(0),$P(^RMPR(664,RMPRA,3),U)=RMPRDELN
73 I Y=4 D G:$D(DTOUT) KILL^RMPR421 S RMPRDELN=$P(^RMPR(664,RMPRA,3),U)
74 .S DIE="^RMPR(664,",DA=RMPRA,DR="19T" D ^DIE
75 .Q
76ASK5 S %=2 W !!,"Are you ready to POST to 10-2319 NOW"
77 S RMPRDFN=$P(^RMPR(664,RMPRA,0),U,2)
78 D YN^DICN G:%=1 FILE^RMPR421B G:$D(DTOUT) KILL^RMPR421
79 I %=0 W !,"This will Create an Entry on the Prosthetic 10-2319 Record" G ASK5
80 I %=-1 S %=2 R !,"Do you want to Delete this Transaction" D YN^DICN G:$D(DTOUT)!(%=1) KILL^RMPR421
81 D ^RMPR4LI I RMPRX]"" G ASK5
82L W !!!,"Enter Item to Edit: " R X:DTIME G:'$T KILL^RMPR421
83 G:"^"[X ASK5 I X["?" D ZDSP G L
84 S DA(1)=RMPRA,DIC="^RMPR(664,"_RMPRA_",1,",DIC(0)="EQMZ" D ^DIC
85 I +Y'>0 K DA,Y G L
86 S:$D(RMPRCTK) RMPRCONT=RMPRCTK
87 S DA=+Y,DA(1)=RMPRA,DR="8;9;I $P(^RMPR(664,DA(1),1,DA,0),U,10)=4 S Y=10;.01;17;1;14;3;2;4;7;S Y="""";10;.01;17;1;14;3;2;4;7"
88 S DIE="^RMPR(664,"_RMPRA_",1," D ^DIE K DA
89 S FL=1 I $D(^RMPR(664,RMPRA,1)) S FL=0 F RI=0:0 S RI=$O(^RMPR(664,RMPRA,1,RI)) Q:RI'>0 I $D(^(RI,0)) S FL=1 I $P(^(0),U,3)=""!($P(^(0),U,4)="")!($P(^(0),U,5)="")!($P(^(0),U,9)="")!($P(^(0),U,10)="") S FL=0 Q
90 I 'FL W !!,?5,$C(7),"REQUIRED ITEMS DO NOT EXIST ON THIS FORM",! G KILL^RMPR421
91 K DA S DIE="^RMPR(664,",DA=RMPRA,DR="11;17;26;20" D ^DIE
92 D G:$D(DTOUT) KILL^RMPR421 G:$D(DUOUT) ASK5
93 .S DIR(0)="SA^1:VETERAN;2:VAMC WAREHOUSE;3:PROSTHETICS;4:OTHER;"
94 .S DIR("A")="DELIVER TO: "
95 .S DIR("B")=$P(^RMPR(664,DA,3),U,1)
96 .D ^DIR K DIR
97 .Q:$D(DTOUT)!($D(DUOUT))
98 .S RMPRDELN=Y(0)
99 .I Y=4 S:'$D(^RMPR(664,RMPRA,3)) ^(3)="" S Y1=Y,DIE="^RMPR(664,",DA=RMPRA,DR="19T" D ^DIE
100 G:$D(DTOUT) KILL^RMPR421 S RMPRDELN=$S($D(Y1):$P(^RMPR(664,RMPRA,3),U),1:RMPRDELN) K Y1 G L
101ZDSP ;MULTIPLE ITEM DISPLAY FOR PURCHASING AND CLOSE-OUT
102 K RAC S RMPRI=0 F S RMPRI=$O(^RMPR(664,RMPRA,1,RMPRI)) Q:RMPRI'>0 S RMPRI1=$P(^(RMPRI,0),U,1),RMPRIT=$P(^RMPR(661,RMPRI1,0),U,1),RAC(RMPRIT)=$P(^PRC(441,RMPRIT,0),U,2)
103 W ! I $D(RAC) W !,?5,"Answer With Item # or Item Name",! F RI=0:0 S RI=$O(RAC(RI)) Q:RI'>0 W !,?5,RI,?10,RAC(RI)
104LDIC I $D(RFL) S X="?",DIC=661,DIC(0)="EQM",DIC("W")="W "" "",$P(^PRC(441,$P(^(0),U,1),0),U,2)" D ^DIC K RFL
105 Q
106PR1 ;PRINT PATIENT NOTIFICATION LETTER
107 S RMPRPN=0,%=2
108 R !,"Would you like to print a Patient Notification letter"
109 D YN^DICN I %=1 S RMPRPN=1 Q
110 G:%=0 HELP1
111 Q:(%=2)!(%=-1)
112 Q
113VCON ;vendor contract
114 K DIR S DIR(0)="PO^PRC(440,"_RMPRV_",4,:QEM" D ^DIR
115 I (Y'>0)&(X'="")&(X'["^") S DIR("B")="" G VCON
116 I X["^" G KILL^RMPR421
117 I Y>0,$P(^PRC(440,RMPRV,4,+Y,0),U,2)<DT W $C(7),!,"Sorry, contract has expired. Enter another contract or `return` to continue." S DR="4//""""" G VCON
118 K DIR,DA
119 S:Y>0 (RMPRCONT,RMPRCTK)=$P(Y,U,2)
120 Q
121HELP1 ;
122 W !,"Enter `Y` for YES to print the Patient Notification letter",!,"`N` for No if you do not wish to print the letter." G PR1
123 Q
124PR ;PRINT THE PRIVACY ACT STATEMENT
125 S %=1 R !,"Would you like to print the Privacy Act Statement" D YN^DICN I %=1 S RMPRPRIV=1 D PR1 Q
126 G:%=0 HELP D:%=2 PR1 Q
127 Q:%=-1
128HELP W !,"Enter `Y` for YES to print the Privacy Act Statement",!,"`N` for NO if you do not want to print the statement." G PR
129 Q
130 ;END
Note: See TracBrowser for help on using the repository browser.