- 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 Feb 19, 2025@00:03:01 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
