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