source: FOIAVistA/trunk/r/REMOTE_ORDER_ENTRY_SYSTEM-RMPF-RMPJ/RMPFET81.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 4.8 KB
Line 
1RMPFET81 ;DDC/KAW-CONTINUATION OF RMPFET8 [ 06/16/95 3:06 PM ]
2 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**20**;MAY 30, 1995
3ADDC ;;Adjustment - Add a component
4 ;; input: RMPFX,RMPFY
5 ;;output: None
6 D REASON G ADDCE:$D(RMPFOUT) S RMPFADD=""
7 S RMPFLG=$S($D(^RMPF(791810,RMPFX,101,RMPFY,102,0)):$P(^(0),U,4),1:"")
8 D COMPON^RMPFET7 G ADDCE:$D(RMPFOUT)
9 I $D(^RMPF(791810,RMPFX,101,RMPFY,102,0)),$P(^(0),U,4)>RMPFLG D STATUS
10ADDCE K RMPFOUT,RMPFQUT,RMPFLG,RMPFADD,RMPFRE Q
11CHANGEM ;;Adjustment - Change model
12 ;; input: RMPFX,RMPFY,RMPFTYP
13 ;;output: None
14 W !!,"Are you sure you wish to change the model? NO// "
15 D READ G CH3:$D(RMPFOUT)
16CH1 I $D(RMPFQUT) W !!,"Enter <Y> to proceed with changing the model, <N> or <RETURN> to continue." G CHANGEM
17 G CH3:Y="" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G CH1
18 G CH3:"Nn"[Y D REASON G CH3:$D(RMPFOUT)
19 S RMPFLR=$P(^RMPF(791810,RMPFX,101,RMPFY,0),U,4)
20 D WARCHCK
21CH2 S DIC="^RMPF(791811,",DIC(0)="AEQM",DIC("A")="Select new model: "
22 S DIC("S")="I $P(^RMPF(791811,+Y,0),U,3),$D(^RMPF(791810.1,RMPFTYP,101,""B"",$P(^RMPF(791811,+Y,0),U,3)))"
23 S RMPFY1=RMPFY W ! D ^DIC G CH3:Y=-1 S RMPFIT=+Y,RMPFITP=$P(Y,U,2)
24 I $D(^RMPF(791811,+Y,"I")),$P(^("I"),U,1) D SURE Q:$D(RMPFOUT) G CH2:"Yy"[Y
25 K RMPFY D ADD1^RMPFET6 G CH2:'$D(RMPFY) S RMPFY2=RMPFY
26 S ^RMPF(791810,RMPFX,101,RMPFY,90)=$G(^RMPF(791810,RMPFX,101,RMPFY1,90))
27 S $P(^RMPF(791810,RMPFX,101,RMPFY,0),U,16)=RMPFY1,$P(^(0),U,15)="OC",$P(^(0),U,4)=RMPFLR
28 S RMPFMESG="Model changed to: "_RMPFITP
29 S X="NOW",%DT="T" D ^%DT S TD=Y
30 S DIE="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX,DA=RMPFY
31 S DR="90.01////"_DUZ_";90.02////"_TD_";90.03////"_RMPFRE_";90.04////"_RMPFMESG D ^DIE
32 D DELETE^RMPFET8
33 S RMPFY=RMPFY2 D STATUS
34 D:$D(RMPFWFLG) ADDWAR
35 W !!,"*** MODEL CHANGED ***" H 1
36CH3 K RMPFOUT,RMPFQUT,X,Y,RMPFRE,DIC,RMPFY1,RMPFIT,RMPFITP,RMPFY2,RMPFMESG
37 K RMPFMESG,RMPFLR,DDH,DISYS,TD Q
38WARCHCK ;;CHECK TO SEE IF OLD MODEL HAS 2ND YEAR WARRANTY
39 K RMPFWFLG
40 S K=0
41 F S K=$O(^RMPF(791810,RMPFX,101,RMPFY,102,K)) Q:'K D:$D(^RMPF(791810,RMPFX,101,RMPFY,102,K,0))
42 .S WR=$P(^RMPF(791810,RMPFX,101,RMPFY,102,K,0),"^",1)
43 .I WR I $P($G(^RMPF(791811.2,WR,0)),"^",3)="WRNTY2YR" S RMPFWFLG=1 Q
44 Q
45ADDWAR ;;ADD 2ND YEAR WARRANTY TO NEW MODEL
46 S X="WRNTY2YR"
47 S DIC=791811.2,DIC(0)="LM" D ^DIC K DIC Q:Y=-1 S X=+Y
48 I '$D(^RMPF(791810,RMPFX,101,RMPFY,102,0)) S ^RMPF(791810,RMPFX,101,RMPFY,102,0)="^791810.101102P^0^0"
49 S DIC="^RMPF(791810,"_RMPFX_",101,"_RMPFY_",102,"
50 S DA(2)=RMPFX,DA(1)=RMPFY,DIC(0)="LM",DLAYGO=791810
51 K DD,DO D FILE^DICN
52 Q
53REMOVEC ;;Adjustment - Remove a component from an order
54 ;; input: RMPFX,RMPFY
55 ;;output: None
56 D REASON G REMOVECE:$D(RMPFOUT)
57RE1 D ARRAY2^RMPFDT2
58 S IT=$P(^RMPF(791810,RMPFX,101,RMPFY,0),U,1)
59 K DIC
60 S DIC="^RMPF(791811.2,",DIC(0)="AEQM",DIC("A")="Select Component: "
61 W ! D ^DIC G REMOVECE:Y=-1 S CP=+Y
62 S X=0 F I=1:1 S X=$O(RMPFC(X)) Q:'X I $P(RMPFC(X),U,1)=CP G RE2
63 W $C(7),!!,"*** COMPONENT IS NOT LISTED IN ORDER ***" G RE1
64RE2 S RMPFZ=X,S0=^RMPF(791810,RMPFX,101,RMPFY,102,RMPFZ,0),X=CP
65 S DIC="^RMPF(791810,"_RMPFX_",101,"_RMPFY_",102,",DIC(0)="L"
66 S DA(2)=RMPFX,DA(1)=RMPFY,DLAYGO=791810 K DO,DD D FILE^DICN
67 I Y=-1 W $C(7),!!,"*** COMPONENT NOT DELETED ***" G REMOVECE
68 S RMPFZ1=+Y,S1=$P(^RMPF(791810,RMPFX,101,RMPFY,102,RMPFZ1,0),U,1)
69 S X="NOW",%DT="T" D ^%DT S TD=Y
70 S S1=S1_U_$P(S0,U,2)_"^D^"_RMPFZ_U_DUZ_U_TD_U_RMPFRE
71 S ^RMPF(791810,RMPFX,101,RMPFY,102,RMPFZ1,0)=S1 D STATUS
72 W !!,"*** COMPONENT REMOVED ***" H 2
73REMOVECE K DIC,CI,IT,Y,X,RMPFRE,S1,TD,RMPFC,RMPFZ,RMPFZ1,M,I,DDHT,DISYS,I,CP,DLAYGO Q
74REASON ;;Enter reason for adjustment
75 ;; input: None
76 ;;output: RMPFRE
77 W !!,"Enter the reason for the adjustment: " D READ Q:$D(RMPFOUT)
78REAS1 I $D(RMPFQUT) W !!,"Enter a free text reason of 3 to 17 characters." G REASON
79 I Y=""!($L(Y)<3)!($L(Y)>17) S RMPFQUT="" G REAS1
80 S RMPFRE=Y
81 K Y Q
82STATUS ;;Set status of line item
83 ;; input: RMPFX,RMPFY
84 ;;output: None
85 S X="NOW",%DT="T" D ^%DT S TD=Y,S0=$G(^RMPF(791810,RMPFX,101,RMPFY,0))
86 S AP=$P(S0,U,20) I 'AP S LA="A" G S2
87 S LA=$P(S0,U,19) I LA="" S LA="A" G S2
88 S LA=$S(LA="O":"A",LA'["A":LA_"A",1:LA)
89S2 S DIE="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX,DA=RMPFY
90 S DR=".19////"_LA_";.17////"_TD_";.2////1;.18///CERTIFICATION PENDING"
91 S X=$G(^RMPF(791810,RMPFX,101,RMPFY,90))
92 I X'="",$P(X,U,13) F I=8:1:11 S $P(^RMPF(791810,RMPFX,101,RMPFY,90),U,I)=""
93S3 D ^DIE
94 K S0,AP,LA,DIE,DR,D0,DA,DQ,D,DIC,DI,X,TD,%DT Q
95SURE W !!,"This item is currently NOT UNDER CONTRACT to the VA."
96 W !,"You may select this item in the adjustment option only."
97 W !!,"Make another selection? NO// " D READ Q:$D(RMPFOUT)
98SURE1 I $D(RMPFQUT) W !!,"Enter an <N> or <RETURN> to continue with this selection",!?7,"a <Y> to make another line item selection." G SURE
99 S:Y="" Y="N" I "NnYy"'[Y S RMPFQUT="" G SURE1
100 Q
101READ K RMPFOUT,RMPFQUT
102 R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
103 I Y?1"^".E S (RMPFOUT,Y)="" Q
104 S:Y?1"?".E (RMPFQUT,Y)=""
105 Q
Note: See TracBrowser for help on using the repository browser.