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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFET81 5024 printed Apr 09, 2024@21:38:38 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
