RMPFET9 ;DDC/KAW-DUPLICATE AN ORDER [ 06/16/95 3:06 PM ]
;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
;; input: RMPFX,RMPFHAT
;;output: RMPFY1
Q:'$D(^RMPF(791810,RMPFX,11)) S RMPFTF=$P(^(11),U,1) Q:RMPFTF'="B"
N RMPFY D ARRAY^RMPFDT2
S (X,CX)=0 F I=1:1 S X=$O(RMPFO(X)) Q:'X S CX=CX+1
G END:CX'=1 K RMPFY1
TWO W !!,"Will the second model be the same as the first? NO// "
D READ G END:$D(RMPFOUT)
TWO1 I $D(RMPFQUT) W !!,"Enter <Y> to order a second model that is the same as the first,",!,"<N> or <RETURN> to continue." G TWO
G END:Y="" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G TWO1
G END:"Nn"[Y S RMPFY=$O(RMPFO(0))
I '$D(^RMPF(791810,RMPFX,101,RMPFY,0)) W $C(7),!!,"*** BAD ORDER INFORMATION ***" G END
W !!,"Adding second model ..."
S S0=^RMPF(791810,RMPFX,101,RMPFY,0)
S RMPFIT=$P(S0,U,1),RMPFLR=$P(S0,U,4),RMPFCS=$P(S0,U,14)
S RMPFBAT=$P(S0,U,2),RMPFID=$P(S0,U,8)
I '$D(^RMPF(791810,RMPFX,101,0)) S ^RMPF(791810,RMPFX,101,0)="^791810.0101P"
S DIC="^RMPF(791810,RMPFX,101,",DA(1)=RMPFX,DIC(0)="L",DLAYGO=791810
S X="NOW",%DT="T" D ^%DT S TD=Y W "."
S X=RMPFIT,DIC("DR")=".04////"_$S(RMPFLR="L":"R",1:"L")_";.14////"_RMPFCS_";.15////O"
I RMPFHAT="S" S DIC("DR")=DIC("DR")_";.02////"_RMPFBAT_";.08////"_RMPFID_";.05;101"
K DD,DO D FILE^DICN I Y=-Y W $C(7),!!,"*** MODEL NOT ADDED ***" G END
S (DA,RMPFY1)=+Y,DIE=DIC,DR=".16////"_+Y_";.17////"_TD_";.18///INCOMPLETE;.19////O;.2////1" D ^DIE W "."
W !!,"*** MODEL ADDED ***"
D ARRAY2^RMPFDT2 S CM="",(X,CX)=0 F I=1:1 S X=$O(RMPFC(X)) Q:'X S CX=CX+1,C=$P(RMPFC(X),U,1) I C,$D(^RMPF(791811.2,C,0)) S CM=$S(I=1:$P(^(0),U,3),1:CM_","_$P(^(0),U,3))
G END:'CX
COM W !!,"The following components were ordered with the first model: ",CM
W !!,"Do you wish to order the same components with the second model? NO// "
D READ G END:$D(RMPFOUT)
COM1 I $D(RMPFQUT) W !!,"Enter <Y> to order the same components for the second model",!,"<N> or <RETURN> to continue." G COM
G COM3:Y="" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G COM1
G COM3:"Nn"[Y S (RMPFZ,CT)=0 W !!,"Adding component(s) ..."
COM2 S RMPFZ=$O(^RMPF(791810,RMPFX,101,RMPFY,102,RMPFZ)) G EXIT:'RMPFZ S S0=^(RMPFZ,0)
S RMPFCOM=$P(S0,U,1),RMPFCX=$P(S0,U,2)
I '$D(^RMPF(791810,RMPFX,101,RMPFY1,102,0)) S ^RMPF(791810,RMPFX,101,RMPFY1,102,0)="^791810.101102P"
S DIC="^RMPF(791810,"_RMPFX_",101,"_RMPFY1_",102," W "."
S DA(2)=RMPFX,DA(1)=RMPFY1,X=RMPFCOM,DIC(0)="L",DLAYGO=791810
S DIC("DR")=".03////O;.05////"_DUZ_";.06////"_TD W "."
K DO,DD D FILE^DICN I Y=-1 W $C(7),!!,"*** COMPONENT NOT ADDED ***" G END
S $P(^RMPF(791810,RMPFX,101,RMPFY1,102,+Y,0),U,4)=+Y W "." S CT=CT+1
G COM2
COM3 S RMPFY=RMPFY1 D COMPON^RMPFET7 G END
EXIT W !!,"*** COMPONENT" W:CT>1 "S" W " ADDED ***"
END K %,%DT,C,CM,CT,CX,D0,DA,DI,DIC,DIE,DR,I,S0,TD,X,Y,ZZ,DQ,DLAYGO,RMPFC
K RMPFCOM,RMPFCS,RMPFCX,RMPFIT,RMPFLR,RMPFO,RMPFTF,RMPFZ,RMPFID
K RMPFOUT,RMPFQUT,RMPFBAT,M,ZY,%Y,RMPFRE,I,RMPFO,RMPFTF,X
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[HRMPFET9 3102 printed Sep 23, 2025@20:12:52 Page 2
RMPFET9 ;DDC/KAW-DUPLICATE AN ORDER [ 06/16/95 3:06 PM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
+2 ;; input: RMPFX,RMPFHAT
+3 ;;output: RMPFY1
+4 if '$DATA(^RMPF(791810,RMPFX,11))
QUIT
SET RMPFTF=$PIECE(^(11),U,1)
if RMPFTF'="B"
QUIT
+5 NEW RMPFY
DO ARRAY^RMPFDT2
+6 SET (X,CX)=0
FOR I=1:1
SET X=$ORDER(RMPFO(X))
if 'X
QUIT
SET CX=CX+1
+7 if CX'=1
GOTO END
KILL RMPFY1
TWO WRITE !!,"Will the second model be the same as the first? NO// "
+1 DO READ
if $DATA(RMPFOUT)
GOTO END
TWO1 IF $DATA(RMPFQUT)
WRITE !!,"Enter <Y> to order a second model that is the same as the first,",!,"<N> or <RETURN> to continue."
GOTO TWO
+1 if Y=""
GOTO END
SET Y=$EXTRACT(Y,1)
IF "YyNn"'[Y
SET RMPFQUT=""
GOTO TWO1
+2 if "Nn"[Y
GOTO END
SET RMPFY=$ORDER(RMPFO(0))
+3 IF '$DATA(^RMPF(791810,RMPFX,101,RMPFY,0))
WRITE $CHAR(7),!!,"*** BAD ORDER INFORMATION ***"
GOTO END
+4 WRITE !!,"Adding second model ..."
+5 SET S0=^RMPF(791810,RMPFX,101,RMPFY,0)
+6 SET RMPFIT=$PIECE(S0,U,1)
SET RMPFLR=$PIECE(S0,U,4)
SET RMPFCS=$PIECE(S0,U,14)
+7 SET RMPFBAT=$PIECE(S0,U,2)
SET RMPFID=$PIECE(S0,U,8)
+8 IF '$DATA(^RMPF(791810,RMPFX,101,0))
SET ^RMPF(791810,RMPFX,101,0)="^791810.0101P"
+9 SET DIC="^RMPF(791810,RMPFX,101,"
SET DA(1)=RMPFX
SET DIC(0)="L"
SET DLAYGO=791810
+10 SET X="NOW"
SET %DT="T"
DO ^%DT
SET TD=Y
WRITE "."
+11 SET X=RMPFIT
SET DIC("DR")=".04////"_$SELECT(RMPFLR="L":"R",1:"L")_";.14////"_RMPFCS_";.15////O"
+12 IF RMPFHAT="S"
SET DIC("DR")=DIC("DR")_";.02////"_RMPFBAT_";.08////"_RMPFID_";.05;101"
+13 KILL DD,DO
DO FILE^DICN
IF Y=-Y
WRITE $CHAR(7),!!,"*** MODEL NOT ADDED ***"
GOTO END
+14 SET (DA,RMPFY1)=+Y
SET DIE=DIC
SET DR=".16////"_+Y_";.17////"_TD_";.18///INCOMPLETE;.19////O;.2////1"
DO ^DIE
WRITE "."
+15 WRITE !!,"*** MODEL ADDED ***"
+16 DO ARRAY2^RMPFDT2
SET CM=""
SET (X,CX)=0
FOR I=1:1
SET X=$ORDER(RMPFC(X))
if 'X
QUIT
SET CX=CX+1
SET C=$PIECE(RMPFC(X),U,1)
IF C
IF $DATA(^RMPF(791811.2,C,0))
SET CM=$SELECT(I=1:$PIECE(^(0),U,3),1:CM_","_$PIECE(^(0),U,3))
+17 if 'CX
GOTO END
COM WRITE !!,"The following components were ordered with the first model: ",CM
+1 WRITE !!,"Do you wish to order the same components with the second model? NO// "
+2 DO READ
if $DATA(RMPFOUT)
GOTO END
COM1 IF $DATA(RMPFQUT)
WRITE !!,"Enter <Y> to order the same components for the second model",!,"<N> or <RETURN> to continue."
GOTO COM
+1 if Y=""
GOTO COM3
SET Y=$EXTRACT(Y,1)
IF "YyNn"'[Y
SET RMPFQUT=""
GOTO COM1
+2 if "Nn"[Y
GOTO COM3
SET (RMPFZ,CT)=0
WRITE !!,"Adding component(s) ..."
COM2 SET RMPFZ=$ORDER(^RMPF(791810,RMPFX,101,RMPFY,102,RMPFZ))
if 'RMPFZ
GOTO EXIT
SET S0=^(RMPFZ,0)
+1 SET RMPFCOM=$PIECE(S0,U,1)
SET RMPFCX=$PIECE(S0,U,2)
+2 IF '$DATA(^RMPF(791810,RMPFX,101,RMPFY1,102,0))
SET ^RMPF(791810,RMPFX,101,RMPFY1,102,0)="^791810.101102P"
+3 SET DIC="^RMPF(791810,"_RMPFX_",101,"_RMPFY1_",102,"
WRITE "."
+4 SET DA(2)=RMPFX
SET DA(1)=RMPFY1
SET X=RMPFCOM
SET DIC(0)="L"
SET DLAYGO=791810
+5 SET DIC("DR")=".03////O;.05////"_DUZ_";.06////"_TD
WRITE "."
+6 KILL DO,DD
DO FILE^DICN
IF Y=-1
WRITE $CHAR(7),!!,"*** COMPONENT NOT ADDED ***"
GOTO END
+7 SET $PIECE(^RMPF(791810,RMPFX,101,RMPFY1,102,+Y,0),U,4)=+Y
WRITE "."
SET CT=CT+1
+8 GOTO COM2
COM3 SET RMPFY=RMPFY1
DO COMPON^RMPFET7
GOTO END
EXIT WRITE !!,"*** COMPONENT"
if CT>1
WRITE "S"
WRITE " ADDED ***"
END KILL %,%DT,C,CM,CT,CX,D0,DA,DI,DIC,DIE,DR,I,S0,TD,X,Y,ZZ,DQ,DLAYGO,RMPFC
+1 KILL RMPFCOM,RMPFCS,RMPFCX,RMPFIT,RMPFLR,RMPFO,RMPFTF,RMPFZ,RMPFID
+2 KILL RMPFOUT,RMPFQUT,RMPFBAT,M,ZY,%Y,RMPFRE,I,RMPFO,RMPFTF,X
+3 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
