source: WorldVistAEHR/trunk/r/REMOTE_ORDER_ENTRY_SYSTEM-RMPF-RMPJ/RMPFET9.m@ 701

Last change on this file since 701 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.0 KB
Line 
1RMPFET9 ;DDC/KAW-DUPLICATE AN ORDER [ 06/16/95 3:06 PM ]
2 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
3 ;; input: RMPFX,RMPFHAT
4 ;;output: RMPFY1
5 Q:'$D(^RMPF(791810,RMPFX,11)) S RMPFTF=$P(^(11),U,1) Q:RMPFTF'="B"
6 N RMPFY D ARRAY^RMPFDT2
7 S (X,CX)=0 F I=1:1 S X=$O(RMPFO(X)) Q:'X S CX=CX+1
8 G END:CX'=1 K RMPFY1
9TWO W !!,"Will the second model be the same as the first? NO// "
10 D READ G END:$D(RMPFOUT)
11TWO1 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
12 G END:Y="" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G TWO1
13 G END:"Nn"[Y S RMPFY=$O(RMPFO(0))
14 I '$D(^RMPF(791810,RMPFX,101,RMPFY,0)) W $C(7),!!,"*** BAD ORDER INFORMATION ***" G END
15 W !!,"Adding second model ..."
16 S S0=^RMPF(791810,RMPFX,101,RMPFY,0)
17 S RMPFIT=$P(S0,U,1),RMPFLR=$P(S0,U,4),RMPFCS=$P(S0,U,14)
18 S RMPFBAT=$P(S0,U,2),RMPFID=$P(S0,U,8)
19 I '$D(^RMPF(791810,RMPFX,101,0)) S ^RMPF(791810,RMPFX,101,0)="^791810.0101P"
20 S DIC="^RMPF(791810,RMPFX,101,",DA(1)=RMPFX,DIC(0)="L",DLAYGO=791810
21 S X="NOW",%DT="T" D ^%DT S TD=Y W "."
22 S X=RMPFIT,DIC("DR")=".04////"_$S(RMPFLR="L":"R",1:"L")_";.14////"_RMPFCS_";.15////O"
23 I RMPFHAT="S" S DIC("DR")=DIC("DR")_";.02////"_RMPFBAT_";.08////"_RMPFID_";.05;101"
24 K DD,DO D FILE^DICN I Y=-Y W $C(7),!!,"*** MODEL NOT ADDED ***" G END
25 S (DA,RMPFY1)=+Y,DIE=DIC,DR=".16////"_+Y_";.17////"_TD_";.18///INCOMPLETE;.19////O;.2////1" D ^DIE W "."
26 W !!,"*** MODEL ADDED ***"
27 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))
28 G END:'CX
29COM W !!,"The following components were ordered with the first model: ",CM
30 W !!,"Do you wish to order the same components with the second model? NO// "
31 D READ G END:$D(RMPFOUT)
32COM1 I $D(RMPFQUT) W !!,"Enter <Y> to order the same components for the second model",!,"<N> or <RETURN> to continue." G COM
33 G COM3:Y="" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G COM1
34 G COM3:"Nn"[Y S (RMPFZ,CT)=0 W !!,"Adding component(s) ..."
35COM2 S RMPFZ=$O(^RMPF(791810,RMPFX,101,RMPFY,102,RMPFZ)) G EXIT:'RMPFZ S S0=^(RMPFZ,0)
36 S RMPFCOM=$P(S0,U,1),RMPFCX=$P(S0,U,2)
37 I '$D(^RMPF(791810,RMPFX,101,RMPFY1,102,0)) S ^RMPF(791810,RMPFX,101,RMPFY1,102,0)="^791810.101102P"
38 S DIC="^RMPF(791810,"_RMPFX_",101,"_RMPFY1_",102," W "."
39 S DA(2)=RMPFX,DA(1)=RMPFY1,X=RMPFCOM,DIC(0)="L",DLAYGO=791810
40 S DIC("DR")=".03////O;.05////"_DUZ_";.06////"_TD W "."
41 K DO,DD D FILE^DICN I Y=-1 W $C(7),!!,"*** COMPONENT NOT ADDED ***" G END
42 S $P(^RMPF(791810,RMPFX,101,RMPFY1,102,+Y,0),U,4)=+Y W "." S CT=CT+1
43 G COM2
44COM3 S RMPFY=RMPFY1 D COMPON^RMPFET7 G END
45EXIT W !!,"*** COMPONENT" W:CT>1 "S" W " ADDED ***"
46END K %,%DT,C,CM,CT,CX,D0,DA,DI,DIC,DIE,DR,I,S0,TD,X,Y,ZZ,DQ,DLAYGO,RMPFC
47 K RMPFCOM,RMPFCS,RMPFCX,RMPFIT,RMPFLR,RMPFO,RMPFTF,RMPFZ,RMPFID
48 K RMPFOUT,RMPFQUT,RMPFBAT,M,ZY,%Y,RMPFRE,I,RMPFO,RMPFTF,X
49 Q
50READ K RMPFOUT,RMPFQUT
51 R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
52 I Y?1"^".E S (RMPFOUT,Y)="" Q
53 S:Y?1"?".E (RMPFQUT,Y)=""
54 Q
Note: See TracBrowser for help on using the repository browser.