106 lines
4.8 KiB
Mathematica
106 lines
4.8 KiB
Mathematica
RMPFET81 ;DDC/KAW-CONTINUATION OF RMPFET8 [ 06/16/95 3:06 PM ]
|
|
;;2.0;REMOTE ORDER/ENTRY SYSTEM;**20**;MAY 30, 1995
|
|
ADDC ;;Adjustment - Add a component
|
|
;; input: RMPFX,RMPFY
|
|
;;output: None
|
|
D REASON G ADDCE:$D(RMPFOUT) S RMPFADD=""
|
|
S RMPFLG=$S($D(^RMPF(791810,RMPFX,101,RMPFY,102,0)):$P(^(0),U,4),1:"")
|
|
D COMPON^RMPFET7 G ADDCE:$D(RMPFOUT)
|
|
I $D(^RMPF(791810,RMPFX,101,RMPFY,102,0)),$P(^(0),U,4)>RMPFLG D STATUS
|
|
ADDCE K RMPFOUT,RMPFQUT,RMPFLG,RMPFADD,RMPFRE Q
|
|
CHANGEM ;;Adjustment - Change model
|
|
;; input: RMPFX,RMPFY,RMPFTYP
|
|
;;output: None
|
|
W !!,"Are you sure you wish to change the model? NO// "
|
|
D READ G CH3:$D(RMPFOUT)
|
|
CH1 I $D(RMPFQUT) W !!,"Enter <Y> to proceed with changing the model, <N> or <RETURN> to continue." G CHANGEM
|
|
G CH3:Y="" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G CH1
|
|
G CH3:"Nn"[Y D REASON G CH3:$D(RMPFOUT)
|
|
S RMPFLR=$P(^RMPF(791810,RMPFX,101,RMPFY,0),U,4)
|
|
D WARCHCK
|
|
CH2 S DIC="^RMPF(791811,",DIC(0)="AEQM",DIC("A")="Select new model: "
|
|
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)))"
|
|
S RMPFY1=RMPFY W ! D ^DIC G CH3:Y=-1 S RMPFIT=+Y,RMPFITP=$P(Y,U,2)
|
|
I $D(^RMPF(791811,+Y,"I")),$P(^("I"),U,1) D SURE Q:$D(RMPFOUT) G CH2:"Yy"[Y
|
|
K RMPFY D ADD1^RMPFET6 G CH2:'$D(RMPFY) S RMPFY2=RMPFY
|
|
S ^RMPF(791810,RMPFX,101,RMPFY,90)=$G(^RMPF(791810,RMPFX,101,RMPFY1,90))
|
|
S $P(^RMPF(791810,RMPFX,101,RMPFY,0),U,16)=RMPFY1,$P(^(0),U,15)="OC",$P(^(0),U,4)=RMPFLR
|
|
S RMPFMESG="Model changed to: "_RMPFITP
|
|
S X="NOW",%DT="T" D ^%DT S TD=Y
|
|
S DIE="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX,DA=RMPFY
|
|
S DR="90.01////"_DUZ_";90.02////"_TD_";90.03////"_RMPFRE_";90.04////"_RMPFMESG D ^DIE
|
|
D DELETE^RMPFET8
|
|
S RMPFY=RMPFY2 D STATUS
|
|
D:$D(RMPFWFLG) ADDWAR
|
|
W !!,"*** MODEL CHANGED ***" H 1
|
|
CH3 K RMPFOUT,RMPFQUT,X,Y,RMPFRE,DIC,RMPFY1,RMPFIT,RMPFITP,RMPFY2,RMPFMESG
|
|
K RMPFMESG,RMPFLR,DDH,DISYS,TD Q
|
|
WARCHCK ;;CHECK TO SEE IF OLD MODEL HAS 2ND YEAR WARRANTY
|
|
K RMPFWFLG
|
|
S K=0
|
|
F S K=$O(^RMPF(791810,RMPFX,101,RMPFY,102,K)) Q:'K D:$D(^RMPF(791810,RMPFX,101,RMPFY,102,K,0))
|
|
.S WR=$P(^RMPF(791810,RMPFX,101,RMPFY,102,K,0),"^",1)
|
|
.I WR I $P($G(^RMPF(791811.2,WR,0)),"^",3)="WRNTY2YR" S RMPFWFLG=1 Q
|
|
Q
|
|
ADDWAR ;;ADD 2ND YEAR WARRANTY TO NEW MODEL
|
|
S X="WRNTY2YR"
|
|
S DIC=791811.2,DIC(0)="LM" D ^DIC K DIC Q:Y=-1 S X=+Y
|
|
I '$D(^RMPF(791810,RMPFX,101,RMPFY,102,0)) S ^RMPF(791810,RMPFX,101,RMPFY,102,0)="^791810.101102P^0^0"
|
|
S DIC="^RMPF(791810,"_RMPFX_",101,"_RMPFY_",102,"
|
|
S DA(2)=RMPFX,DA(1)=RMPFY,DIC(0)="LM",DLAYGO=791810
|
|
K DD,DO D FILE^DICN
|
|
Q
|
|
REMOVEC ;;Adjustment - Remove a component from an order
|
|
;; input: RMPFX,RMPFY
|
|
;;output: None
|
|
D REASON G REMOVECE:$D(RMPFOUT)
|
|
RE1 D ARRAY2^RMPFDT2
|
|
S IT=$P(^RMPF(791810,RMPFX,101,RMPFY,0),U,1)
|
|
K DIC
|
|
S DIC="^RMPF(791811.2,",DIC(0)="AEQM",DIC("A")="Select Component: "
|
|
W ! D ^DIC G REMOVECE:Y=-1 S CP=+Y
|
|
S X=0 F I=1:1 S X=$O(RMPFC(X)) Q:'X I $P(RMPFC(X),U,1)=CP G RE2
|
|
W $C(7),!!,"*** COMPONENT IS NOT LISTED IN ORDER ***" G RE1
|
|
RE2 S RMPFZ=X,S0=^RMPF(791810,RMPFX,101,RMPFY,102,RMPFZ,0),X=CP
|
|
S DIC="^RMPF(791810,"_RMPFX_",101,"_RMPFY_",102,",DIC(0)="L"
|
|
S DA(2)=RMPFX,DA(1)=RMPFY,DLAYGO=791810 K DO,DD D FILE^DICN
|
|
I Y=-1 W $C(7),!!,"*** COMPONENT NOT DELETED ***" G REMOVECE
|
|
S RMPFZ1=+Y,S1=$P(^RMPF(791810,RMPFX,101,RMPFY,102,RMPFZ1,0),U,1)
|
|
S X="NOW",%DT="T" D ^%DT S TD=Y
|
|
S S1=S1_U_$P(S0,U,2)_"^D^"_RMPFZ_U_DUZ_U_TD_U_RMPFRE
|
|
S ^RMPF(791810,RMPFX,101,RMPFY,102,RMPFZ1,0)=S1 D STATUS
|
|
W !!,"*** COMPONENT REMOVED ***" H 2
|
|
REMOVECE K DIC,CI,IT,Y,X,RMPFRE,S1,TD,RMPFC,RMPFZ,RMPFZ1,M,I,DDHT,DISYS,I,CP,DLAYGO Q
|
|
REASON ;;Enter reason for adjustment
|
|
;; input: None
|
|
;;output: RMPFRE
|
|
W !!,"Enter the reason for the adjustment: " D READ Q:$D(RMPFOUT)
|
|
REAS1 I $D(RMPFQUT) W !!,"Enter a free text reason of 3 to 17 characters." G REASON
|
|
I Y=""!($L(Y)<3)!($L(Y)>17) S RMPFQUT="" G REAS1
|
|
S RMPFRE=Y
|
|
K Y Q
|
|
STATUS ;;Set status of line item
|
|
;; input: RMPFX,RMPFY
|
|
;;output: None
|
|
S X="NOW",%DT="T" D ^%DT S TD=Y,S0=$G(^RMPF(791810,RMPFX,101,RMPFY,0))
|
|
S AP=$P(S0,U,20) I 'AP S LA="A" G S2
|
|
S LA=$P(S0,U,19) I LA="" S LA="A" G S2
|
|
S LA=$S(LA="O":"A",LA'["A":LA_"A",1:LA)
|
|
S2 S DIE="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX,DA=RMPFY
|
|
S DR=".19////"_LA_";.17////"_TD_";.2////1;.18///CERTIFICATION PENDING"
|
|
S X=$G(^RMPF(791810,RMPFX,101,RMPFY,90))
|
|
I X'="",$P(X,U,13) F I=8:1:11 S $P(^RMPF(791810,RMPFX,101,RMPFY,90),U,I)=""
|
|
S3 D ^DIE
|
|
K S0,AP,LA,DIE,DR,D0,DA,DQ,D,DIC,DI,X,TD,%DT Q
|
|
SURE W !!,"This item is currently NOT UNDER CONTRACT to the VA."
|
|
W !,"You may select this item in the adjustment option only."
|
|
W !!,"Make another selection? NO// " D READ Q:$D(RMPFOUT)
|
|
SURE1 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
|
|
S:Y="" Y="N" I "NnYy"'[Y S RMPFQUT="" G SURE1
|
|
Q
|
|
READ K RMPFOUT,RMPFQUT
|
|
R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
|
|
I Y?1"^".E S (RMPFOUT,Y)="" Q
|
|
S:Y?1"?".E (RMPFQUT,Y)=""
|
|
Q
|