Routine: RMPFET81

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

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

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

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)=""

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFET81   5024     printed  Apr 23, 2025@18:50:58                                                                                                                                                                                                    Page 2

RMPFET81  ;DDC/KAW-CONTINUATION OF RMPFET8 [ 06/16/95   3:06 PM ]

 +1       ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**20**;MAY 30, 1995

ADDC      ;;Adjustment - Add a component

 +1       ;; input: RMPFX,RMPFY

 +2       ;;output: None

 +3        DO REASON

           if $DATA(RMPFOUT)

               GOTO ADDCE

           SET RMPFADD=""

 +4        SET RMPFLG=$SELECT($DATA(^RMPF(791810,RMPFX,101,RMPFY,102,0)):$PIECE(^(0),U,4),1:"")

 +5        DO COMPON^RMPFET7

           if $DATA(RMPFOUT)

               GOTO ADDCE

 +6        IF $DATA(^RMPF(791810,RMPFX,101,RMPFY,102,0))

               IF $PIECE(^(0),U,4)>RMPFLG

                   DO STATUS

ADDCE      KILL RMPFOUT,RMPFQUT,RMPFLG,RMPFADD,RMPFRE

           QUIT

CHANGEM   ;;Adjustment - Change model

 +1       ;; input: RMPFX,RMPFY,RMPFTYP

 +2       ;;output: None

 +3        WRITE !!,"Are you sure you wish to change the model? NO// "

 +4        DO READ

           if $DATA(RMPFOUT)

               GOTO CH3

CH1        IF $DATA(RMPFQUT)

               WRITE !!,"Enter <Y> to proceed with changing the model, <N> or <RETURN> to continue."

               GOTO CHANGEM

 +1        if Y=""

               GOTO CH3

           SET Y=$EXTRACT(Y,1)

           IF "YyNn"'[Y

               SET RMPFQUT=""

               GOTO CH1

 +2        if "Nn"[Y

               GOTO CH3

           DO REASON

           if $DATA(RMPFOUT)

               GOTO CH3

 +3        SET RMPFLR=$PIECE(^RMPF(791810,RMPFX,101,RMPFY,0),U,4)

 +4        DO WARCHCK

CH2        SET DIC="^RMPF(791811,"

           SET DIC(0)="AEQM"

           SET DIC("A")="Select new model: "

 +1        SET DIC("S")="I $P(^RMPF(791811,+Y,0),U,3),$D(^RMPF(791810.1,RMPFTYP,101,""B"",$P(^RMPF(791811,+Y,0),U,3)))"

 +2        SET RMPFY1=RMPFY

           WRITE !

           DO ^DIC

           if Y=-1

               GOTO CH3

           SET RMPFIT=+Y

           SET RMPFITP=$PIECE(Y,U,2)

 +3        IF $DATA(^RMPF(791811,+Y,"I"))

               IF $PIECE(^("I"),U,1)

                   DO SURE

                   if $DATA(RMPFOUT)

                       QUIT

                   if "Yy"[Y

                       GOTO CH2

 +4        KILL RMPFY

           DO ADD1^RMPFET6

           if '$DATA(RMPFY)

               GOTO CH2

           SET RMPFY2=RMPFY

 +5        SET ^RMPF(791810,RMPFX,101,RMPFY,90)=$GET(^RMPF(791810,RMPFX,101,RMPFY1,90))

 +6        SET $PIECE(^RMPF(791810,RMPFX,101,RMPFY,0),U,16)=RMPFY1

           SET $PIECE(^(0),U,15)="OC"

           SET $PIECE(^(0),U,4)=RMPFLR

 +7        SET RMPFMESG="Model changed to: "_RMPFITP

 +8        SET X="NOW"

           SET %DT="T"

           DO ^%DT

           SET TD=Y

 +9        SET DIE="^RMPF(791810,"_RMPFX_",101,"

           SET DA(1)=RMPFX

           SET DA=RMPFY

 +10       SET DR="90.01////"_DUZ_";90.02////"_TD_";90.03////"_RMPFRE_";90.04////"_RMPFMESG

           DO ^DIE

 +11       DO DELETE^RMPFET8

 +12       SET RMPFY=RMPFY2

           DO STATUS

 +13       if $DATA(RMPFWFLG)

               DO ADDWAR

 +14       WRITE !!,"*** MODEL CHANGED ***"

           HANG 1

CH3        KILL RMPFOUT,RMPFQUT,X,Y,RMPFRE,DIC,RMPFY1,RMPFIT,RMPFITP,RMPFY2,RMPFMESG

 +1        KILL RMPFMESG,RMPFLR,DDH,DISYS,TD

           QUIT

WARCHCK   ;;CHECK TO SEE IF OLD MODEL HAS 2ND YEAR WARRANTY

 +1        KILL RMPFWFLG

 +2        SET K=0

 +3        FOR

               SET K=$ORDER(^RMPF(791810,RMPFX,101,RMPFY,102,K))

               if 'K

                   QUIT

               if $DATA(^RMPF(791810,RMPFX,101,RMPFY,102,K,0))

                   Begin DoDot:1

 +4                    SET WR=$PIECE(^RMPF(791810,RMPFX,101,RMPFY,102,K,0),"^",1)

 +5                    IF WR

                           IF $PIECE($GET(^RMPF(791811.2,WR,0)),"^",3)="WRNTY2YR"

                               SET RMPFWFLG=1

                               QUIT

                   End DoDot:1

 +6        QUIT

ADDWAR    ;;ADD 2ND YEAR WARRANTY TO NEW MODEL

 +1        SET X="WRNTY2YR"

 +2        SET DIC=791811.2

           SET DIC(0)="LM"

           DO ^DIC

           KILL DIC

           if Y=-1

               QUIT

           SET X=+Y

 +3        IF '$DATA(^RMPF(791810,RMPFX,101,RMPFY,102,0))

               SET ^RMPF(791810,RMPFX,101,RMPFY,102,0)="^791810.101102P^0^0"

 +4        SET DIC="^RMPF(791810,"_RMPFX_",101,"_RMPFY_",102,"

 +5        SET DA(2)=RMPFX

           SET DA(1)=RMPFY

           SET DIC(0)="LM"

           SET DLAYGO=791810

 +6        KILL DD,DO

           DO FILE^DICN

 +7        QUIT

REMOVEC   ;;Adjustment - Remove a component from an order

 +1       ;; input: RMPFX,RMPFY

 +2       ;;output: None

 +3        DO REASON

           if $DATA(RMPFOUT)

               GOTO REMOVECE

RE1        DO ARRAY2^RMPFDT2

 +1        SET IT=$PIECE(^RMPF(791810,RMPFX,101,RMPFY,0),U,1)

 +2        KILL DIC

 +3        SET DIC="^RMPF(791811.2,"

           SET DIC(0)="AEQM"

           SET DIC("A")="Select Component: "

 +4        WRITE !

           DO ^DIC

           if Y=-1

               GOTO REMOVECE

           SET CP=+Y

 +5        SET X=0

           FOR I=1:1

               SET X=$ORDER(RMPFC(X))

               if 'X

                   QUIT

               IF $PIECE(RMPFC(X),U,1)=CP

                   GOTO RE2

 +6        WRITE $CHAR(7),!!,"*** COMPONENT IS NOT LISTED IN ORDER ***"

           GOTO RE1

RE2        SET RMPFZ=X

           SET S0=^RMPF(791810,RMPFX,101,RMPFY,102,RMPFZ,0)

           SET X=CP

 +1        SET DIC="^RMPF(791810,"_RMPFX_",101,"_RMPFY_",102,"

           SET DIC(0)="L"

 +2        SET DA(2)=RMPFX

           SET DA(1)=RMPFY

           SET DLAYGO=791810

           KILL DO,DD

           DO FILE^DICN

 +3        IF Y=-1

               WRITE $CHAR(7),!!,"*** COMPONENT NOT DELETED ***"

               GOTO REMOVECE

 +4        SET RMPFZ1=+Y

           SET S1=$PIECE(^RMPF(791810,RMPFX,101,RMPFY,102,RMPFZ1,0),U,1)

 +5        SET X="NOW"

           SET %DT="T"

           DO ^%DT

           SET TD=Y

 +6        SET S1=S1_U_$PIECE(S0,U,2)_"^D^"_RMPFZ_U_DUZ_U_TD_U_RMPFRE

 +7        SET ^RMPF(791810,RMPFX,101,RMPFY,102,RMPFZ1,0)=S1

           DO STATUS

 +8        WRITE !!,"*** COMPONENT REMOVED ***"

           HANG 2

REMOVECE   KILL DIC,CI,IT,Y,X,RMPFRE,S1,TD,RMPFC,RMPFZ,RMPFZ1,M,I,DDHT,DISYS,I,CP,DLAYGO

           QUIT

REASON    ;;Enter reason for adjustment

 +1       ;; input: None

 +2       ;;output: RMPFRE

 +3        WRITE !!,"Enter the reason for the adjustment: "

           DO READ

           if $DATA(RMPFOUT)

               QUIT

REAS1      IF $DATA(RMPFQUT)

               WRITE !!,"Enter a free text reason of 3 to 17 characters."

               GOTO REASON

 +1        IF Y=""!($LENGTH(Y)<3)!($LENGTH(Y)>17)

               SET RMPFQUT=""

               GOTO REAS1

 +2        SET RMPFRE=Y

 +3        KILL Y

           QUIT

STATUS    ;;Set status of line item

 +1       ;; input: RMPFX,RMPFY

 +2       ;;output: None

 +3        SET X="NOW"

           SET %DT="T"

           DO ^%DT

           SET TD=Y

           SET S0=$GET(^RMPF(791810,RMPFX,101,RMPFY,0))

 +4        SET AP=$PIECE(S0,U,20)

           IF 'AP

               SET LA="A"

               GOTO S2

 +5        SET LA=$PIECE(S0,U,19)

           IF LA=""

               SET LA="A"

               GOTO S2

 +6        SET LA=$SELECT(LA="O":"A",LA'["A":LA_"A",1:LA)

S2         SET DIE="^RMPF(791810,"_RMPFX_",101,"

           SET DA(1)=RMPFX

           SET DA=RMPFY

 +1        SET DR=".19////"_LA_";.17////"_TD_";.2////1;.18///CERTIFICATION PENDING"

 +2        SET X=$GET(^RMPF(791810,RMPFX,101,RMPFY,90))

 +3        IF X'=""

               IF $PIECE(X,U,13)

                   FOR I=8:1:11

                       SET $PIECE(^RMPF(791810,RMPFX,101,RMPFY,90),U,I)=""

S3         DO ^DIE

 +1        KILL S0,AP,LA,DIE,DR,D0,DA,DQ,D,DIC,DI,X,TD,%DT

           QUIT

SURE       WRITE !!,"This item is currently NOT UNDER CONTRACT to the VA."

 +1        WRITE !,"You may select this item in the adjustment option only."

 +2        WRITE !!,"Make another selection? NO// "

           DO READ

           if $DATA(RMPFOUT)

               QUIT

SURE1      IF $DATA(RMPFQUT)

               WRITE !!,"Enter an <N> or <RETURN> to continue with this selection",!?7,"a <Y> to make another line item selection."

               GOTO SURE

 +1        if Y=""

               SET Y="N"

           IF "NnYy"'[Y

               SET RMPFQUT=""

               GOTO SURE1

 +2        QUIT

READ       KILL RMPFOUT,RMPFQUT

 +1        READ Y:DTIME

           IF '$TEST

               WRITE $CHAR(7)

               READ Y:5

               if Y="."

                   GOTO READ

               if '$TEST

                   SET Y=U

 +2        IF Y?1"^".E

               SET (RMPFOUT,Y)=""

               QUIT

 +3        if Y?1"?".E

               SET (RMPFQUT,Y)=""

 +4        QUIT

RMPFET81.m