source: FOIAVistA/trunk/r/REMOTE_ORDER_ENTRY_SYSTEM-RMPF-RMPJ/RMPFET7.m@ 1674

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

initial load of FOIAVistA 6/30/08 version
File size: 5.1 KB
Line 
1RMPFET7 ;DDC/KAW-SPECIAL EDIT SUB-ROUTINES [ 06/16/95 3:06 PM ]
2 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**17**;06/06/01
3ISSUE ;; input: RMPFX,RMPFTYP,RMPFHAT,DFN
4 ;;output: None
5 S NB=12 D AUTH^RMPFET71 G END:$D(RMPFOUT) D PAT^RMPFUTL
6START W @IOF,!?36,"EXISTING ORDER"
7 W !,"Patient: ",RMPFNAM,?64,"SSN: ",RMPFSSN
8 W ! F I=1:1:80 W "-"
9 D ^RMPFDT2 K RMPF S (X,CK)=0 F S X=$O(RMPFO(X)) Q:'X D
10 .Q:'$D(^RMPF(791810,RMPFX,101,X,0)) S S0=^(0),SN=$P(S0,U,5)
11 .I SN'="",$D(SN(SN)) W $C(7),!!,"*** DUPLICATE SERIAL NUMBERS IN ORDER ***" Q
12 .I SN'="" S SN(SN)=""
13 .Q:$P(S0,U,15)="C" S Y=$P(S0,U,18)
14 .I Y,$D(^RMPF(791810.2,Y,0)) S Y=$P(^(0),U,2) I Y'="","EDS"[Y S CK=CK+1,RMPF(CK)=X
15 K SN
16 I CK=0 W !!,"*** NO LINE ITEMS TO ISSUE ***",!!,"Enter <RETURN> to continue." D READ G END
17A1 W !!,"Enter <I>ssue or <RETURN> to exit. "
18 D READ G END:$D(RMPFOUT)
19A11 I $D(RMPFQUT) W !!,"Enter an <I> to issue line item(s) or <RETURN> to exit." G A1
20 G END:Y="" S Y=$E(Y,1) G END:"Ii"'[Y
21 I CK=1 S PT=1,RMPFY=RMPF(1) D CAN G END:$D(RMPFOUT) G START
22ASK W !!,"Issue ",CK," line items? YES// " D READ G END:$D(RMPFOUT)
23ASK1 I $D(RMPFQUT) W !!,"Enter a <Y> or <RETURN> to issue ",CK," line items",!?5,"an <N> to exit." G ASK
24 S:Y="" Y="Y" S Y=$E(Y,1)
25 I "YyNn"'[Y S RMPFQUT="" G ASK1
26 G SEL:"Nn"[Y S PT=0
27LOOP S PT=$O(RMPF(PT)) G LOOPE:'PT
28 S RMPFY=RMPF(PT) D CAN G LOOPE:$D(RMPFOUT),LOOP
29LOOPE G START
30SEL W !!,"Select number of item to issue: "
31 D READ G END:$D(RMPFOUT)
32SEL1 I $D(RMPFQUT) W !!,"Enter the number to the left of the item you wish to issue",!,"or <RETURN> to continue." G SEL
33 G END:Y="" I '$D(RMPFMD(Y)) S RMPFQUT="" G SEL1
34 S (DA,RMPFY)=RMPFMD(Y),PT=Y D CAN G END:$D(RMPFOUT)
35 G START
36CAN ;; input: RMPFX,RMPFY,PT,CK,RMPFMD,RMPFTYP
37 ;;output: None
38 I $P(^RMPF(791810,RMPFX,101,RMPFY,0),U,15)="C" W $C(7),!!,"*** THIS LINE ITEM HAS BEEN CANCELED ***" Q
39 S X=$P(^RMPF(791810,RMPFX,101,RMPFY,0),U,18) Q:'X
40 Q:'$D(^RMPF(791810.2,X,0)) S RMPFSTO=$P(^(0),U,2)
41 I "ED"[RMPFSTO D CLEAR^RMPFET61 Q:'$D(RMPFSTO)
42 I "DES"'[RMPFSTO W $C(7),!!,"*** LINE ITEMS WITH THIS STATUS CANNOT BE ISSUED ***" H 1 K RMPFY Q
43 I '$P($G(^RMPF(791810,RMPFX,101,RMPFY,90)),U,9) W $C(7),!!,"*** THIS LINE ITEM HAS NOT BEEN CERTIFIED *** " H 1 K RMPFY Q
44 D ^RMPFET71 Q:$D(RMPFOUT)
45EXIT1 K X,RMPFSTO,DIE,DA,DR Q
46END K %,%DT,%Y,CK,CX,D,D0,D1,DA,DI,DIC,DIE,DQ,DR,RMPFMD,RMPFO,RMPFDOB,NB
47 K RMPFNAM,RMPFSSN,PT,SN,Y,RMPFLA,RMPFSTO,S,X,RMPFY,RMPFDOD,RMPF,S0,CM,K Q
48COMPON ;;Add/Edit a component
49 ;; input: RMPFX,RMPFY,RMPFADD (opt.),RMPFRE (opt.)
50 ;;output: RMPFRE
51 D ARRAY2^RMPFDT2 S:'$D(RMPFRE) RMPFRE=""
52 S IT=$P(^RMPF(791810,RMPFX,101,RMPFY,0),U,1) Q:IT=1
53 S DIC("S")="I $D(^RMPF(791811,IT,101,""B"",Y))"
54COM1 ;W !,"SELECT COMPONENT: "
55 D READ1 G COME:$D(RMPFOUT)
56COM11 ;I $D(RMPFQUT) S X="?" G COM12
57 G COME:Y=""
58 S X=Y
59COM12 I '$D(^RMPF(791810,RMPFX,101,RMPFY,102,0)) S ^RMPF(791810,RMPFX,101,RMPFY,102,0)="^791810.101102P"
60 ;S DIC=791811.2,DIC(0)="EQM" D ^DIC K DIC G COMPON:Y=-1
61 S IX=0 F I=1:1 S IX=$O(RMPFC(IX)) Q:'IX I $P(RMPFC(IX),U,1)=+Y D DEL G COMPON
62 D NEW S X=+Y,DIC="^RMPF(791810,"_RMPFX_",101,"_RMPFY_",102,"
63 S DA(2)=RMPFX,DA(1)=RMPFY,DIC(0)="LN",DLAYGO=791810
64 K DD,DO D FILE^DICN I Y=-1 W $C(7),!!,"*** COMPONENT NOT ADDED ***" H 2 G COMPON
65 S RMPFZ=+Y,SX=^RMPF(791810,RMPFX,101,RMPFY,102,RMPFZ,0)
66 S $P(SX,U,3)=$S('$D(RMPFADD):"O",1:"A"),$P(SX,U,4)=+Y
67 G COM2:'$D(RMPFADD) S $P(SX,U,5)=DUZ,$P(SX,U,7)=RMPFRE
68 S X="NOW",%DT="T" D ^%DT S $P(SX,U,6)=Y
69COM2 S ^RMPF(791810,RMPFX,101,RMPFY,102,RMPFZ,0)=SX G COMPON
70COME K IT,DIC,X,Y,IX,I,RMPFC,DA,RMPFZ,SX,RMPFADD,%,%DT,DIR
71 K DISYS,DLAYGO,DIK,M,RMPFQUT Q
72DEL S CM=$P(^RMPF(791811.2,+Y,0),U,1)
73 W !!,"The component you chose (",CM,") has already been added to this aid."
74 W !!,"Do you wish to delete the ",CM,"? NO// " D READ Q:$D(RMPFOUT)
75DEL1 I $D(RMPFQUT) W !!,"Enter a <Y> to delete the component",!?6,"a <N> or <RETURN> to keep the component on order." G DEL
76 S:Y="" Y="N" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G DEL1
77 Q:"Nn"[Y
78 S DIK="^RMPF(791810,"_RMPFX_",101,"_RMPFY_",102,",DA=IX,DA(1)=RMPFY,DA(2)=RMPFX
79 D ^DIK
80 Q
81SECOND Q:'$D(RMPFX) Q:'$D(RMPFY)
82 Q:'$D(^RMPF(791810,RMPFX,101,RMPFY,0)) S SZ=^(0)
83 S SU=$P(SZ,U,1) I SU,$D(^RMPF(791811,SU,0)),$P(^(0),U,7) D
84 .I $D(^RMPF(791810,RMPFX,101,RMPFY,2)) S X=$P(^(2),U,3) I X,$D(^RMPF(791811.3,X,0)) S DIC("B")=$P(^(0),U,1)
85 .S DIC=791811.3,DIC("A")="SECOND BATTERY TYPE: "
86 .S DIC(0)="AEQM"
87 .D ^DIC I Y'=-1 S $P(^RMPF(791810,RMPFX,101,RMPFY,2),U,3)=+Y
88 .Q
89 K SU,SZ,X,Y,DIC Q
90READ K RMPFOUT,RMPFQUT
91 R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
92 I Y?1"^".E S (RMPFOUT,Y)="" Q
93 S:Y?1"?".E (RMPFQUT,Y)=""
94 Q
95READ1 K DIR,RMPFOUT,RMPFQUT
96 S DIR(0)="PO^791811.2:EMZ"
97 S DIR("A")="SELECT COMPONENT"
98 S:$P($G(^RMPF(791810.1,RMPFTYP,0)),U,2)="C" DIR("S")="I $P(^RMPF(791811.2,Y,0),U,4)=1"
99 S:$P($G(^RMPF(791810.1,RMPFTYP,0)),U,2)="X" DIR("S")="I $P(^RMPF(791811.2,Y,0),U,5)'=1"
100 D ^DIR
101 S:$E(X,1)="^" (RMPFOUT,Y)=""
102 S:X="" Y=""
103 Q
104NEW N DIC,DA,DR,DO,DD,DQ,D0,DP Q
105CHECK ;; input: RMPFTYP
106 ;;output: DIC("S"),RMPF
107 K DIC("S") Q:'$D(RMPFTYP) Q:RMPFTYP=15 K RM S K=0
108 F S K=$O(^RMPF(791810.1,RMPFTYP,103,K)) Q:'K I $D(^(K,0)) S RMPF($E($P(^(0),U,1),1))=""
109 S DIC("S")="S Z1=$E(X,1) I $D(RMPF(Z1))"
110CHECKE Q
Note: See TracBrowser for help on using the repository browser.