source: FOIAVistA/tag/r/REMOTE_ORDER_ENTRY_SYSTEM-RMPF-RMPJ/RMPFET6.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 4.6 KB
Line 
1RMPFET6 ;DDC/KAW-EDIT LINE ITEM INFORMATION [ 05/12/98 1:45 PM ]
2 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**20**;MAY 30, 1995
3 ;; input: RMPFX,RMPFTP,RMPFTYP,RMPFHAT,RMPFST,DFN (if patient order)
4 ;;output: None
5 Q:'$D(RMPFX) S X=$G(^RMPF(791810,RMPFX,0)) Q:X=""
6START K RMPFMD,RMPFY D ARRAY^RMPFDT2
7 S (X,RMPFMC)=0 F S X=$O(RMPFO(X)) Q:'X S RMPFMC=RMPFMC+1
8 I 'RMPFMC S Y1="A" G ST1
9 D:RMPFTP="P" PAT^RMPFUTL
10 W @IOF,!?33,"ITEMS ORDERED" D @("HEAD"_RMPFTP_"^RMPFDT1")
11 W !! D ^RMPFDT2 K RMPFY
12 D ^RMPFET62 G END:$D(RMPFOUT),END:'$D(Y1)
13 I "Dd"[Y1,$D(RMPFY) D DELETE G END
14ST1 I "Aa"[Y1 D ADD G END:$D(RMPFOUT),END:'$D(RMPFY)
15 D EDIT G END:$D(RMPFOUT),START
16END K CX,SX,RMPFDOB,RMPFDOD,RMPFMC,RMPFMD,RMPFNAM,RMPFO,RMPFSSN,Y1
17 K RMPFSTR0,RMPFSTR2,RMPFSTR3 Q
18 ;
19ADD ;;Add a new line item
20 ;; input: RMPFX,RMPFTYP,RMPFHAT,RMPFST
21 ;;output: RMPFY,RMPFIT,RMPFITP
22 K RMPFIT
23 D SELECT G ADDE:$D(RMPFOUT),ADDE:'$D(RMPFIT)
24ADD1 I '$D(^RMPF(791810,RMPFX,101,0)) S ^RMPF(791810,RMPFX,101,0)="^791810.0101P"
25 S %DT="T",X="NOW" D ^%DT
26 S DIC="^RMPF(791810,"_RMPFX_",101,",(DA,DA(1))=RMPFX,X=RMPFIT
27 S DIC(0)="L",DLAYGO=791810,DIC("DR")=".15////O;.17////"_Y_";.18///1;.19////O;.2////1"
28 S:RMPFIT=1 DIC("DR")=DIC("DR")_";2.01;2.02"
29 K DD,DO D FILE^DICN
30 I Y=-1 W !!,"*** UNABLE TO ADD LINE ITEM ***" G ADDE
31 S RMPFY=+Y I RMPFIT=1 D G ADDE:'$D(RMPFY)
32 .Q:RMPFHAT="E"
33 .I $D(^RMPF(791810,RMPFX,101,RMPFY,2)),$P(^(2),U,2)'="" Q
34 .S DA=RMPFY,DIK="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX
35 .D ^DIK K RMPFY
36 G ADDE:'$D(RMPFY)
37 S DIE="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX,DA=RMPFY
38 S DR=".16////"_RMPFY D ^DIE
39 K RMPF F I=5,10,11 S RMPF(I)=""
40ADDE K DI,DIE,DQ,DR,DIC,DIK,X,Y,DA,DD,D0,RMPF,ZY,ZZ,%,D,%DT,I Q
41 ;
42EDIT ;;Edit information for a line item
43 ;; input: RMPFX,RMPFY,Y1,RMPFTYP,RMPFHAT,RMPFST
44 ;;output: None
45 Q:'$D(RMPFX)!'$D(RMPFY)
46 S RMPFSTO=$P(^RMPF(791810,RMPFX,101,RMPFY,0),U,18) S:RMPFSTO="" RMPFSTO=1
47 I $P(^RMPF(791810.2,RMPFSTO,0),U,5)'="E" W !!,$C(7),"*** THIS LINE ITEM IS IN A STATUS THAT IS UNEDITABLE ***" H 2 G EDITE
48 I RMPFSTO=6!(RMPFSTO=7)!(RMPFSTO=10) D CLEAR^RMPFET61 G EDITE:'$D(RMPFSTO)
49 D PRIOR^RMPFET61 G ED1:"Aa"[Y1
50 S X=$P(^RMPF(791810,RMPFX,101,RMPFY,0),U,1) I X,$D(^RMPF(791811,X,0)) S DIC("B")=$P(^(0),U,1)
51 I RMPFHAT="E" S RMPFIT=1 G ED1
52 D SELECT G EDITE:$D(RMPFOUT),EDITE:'$D(RMPFIT)
53ED1 S RMPFPGP=$P(^RMPF(791811,RMPFIT,0),U,3) I RMPFPGP,$D(^RMPF(791811.1,RMPFPGP,0)) S RMPFPGP=$P(^(0),U,2)
54 S DR=$P($G(^RMPF(791810.1,RMPFTYP,1)),U,1)
55 I RMPFTYP=2 I $D(^RMPF(791811,RMPFIT,0)) I $P(^(0),"^",1)["REMOTE" D
56 .S $P(DR,";",1)=$P(DR,";",1)_"////^S X=""R"""
57 S ST=".01////"_RMPFIT I RMPFIT=1 S ST=ST_";2.01;2.02"
58 S DR=$S(DR'="":ST_";"_DR,1:ST_RMPFIT)
59 I RMPFIT'=$P(^RMPF(791810,RMPFX,101,RMPFY,0),U,1) K ^RMPF(791810,RMPFX,101,RMPFY,102)
60 S DIE="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX,DA=RMPFY D ^DIE
61 D ^RMPFET61
62 I "CS"[RMPFHAT D
63 .S RMPFY=9999 D PRIOR^RMPFET61,^RMPFET9
64 .I $D(RMPFY1) S RMPFY=RMPFY1 D ^RMPFET61
65EDITE K X,Y,Y1,%Y,D0,DI,DIE,DQ,DR,RMPFTF,RMPFRE,RMPFIT,RMPFITP,RMPFO,RMPFPGP
66 K %,CX,D,D1,DA,DIC,DLAYGO,RMPFSTO,I,DISYS,RMPFSTR0,RMPFSTR2,RMPFSTR3,ST Q
67 ;
68SELECT ;;Select a line item from 791811
69 ;; input: RMPFTYP,RMPFST
70 ;;output: RMPFIT,RMPFITP
71 S SL=$P(^RMPF(791810.1,RMPFTYP,0),U,9)
72 I SL=2 S RMPFIT=1,RMPFITP=$P(^RMPF(791811,1,0),U,1) G SELECTE
73 I SL=1 S DIC("S")="S Z1=$P(^RMPF(791811,Y,0),U,3) Q:'Z1 I Y=1!($D(^RMPF(791810.1,RMPFTYP,101,""B"",Z1)))" G SE0
74 I $O(^RMPF(791810.1,RMPFTYP,101,"B",0)) D G SE0
75 .I RMPFTYP'=8 S DIC("S")="I Y,Y'=1,'$P($G(^RMPF(791811,Y,""I"")),U,1) S Z1=$P(^RMPF(791811,Y,0),U,3) I Z1,$D(^RMPF(791810.1,RMPFTYP,101,""B"",Z1))"
76 .I RMPFTYP=8 S DIC("S")="I Y,Y'=1 S Z1=$P(^RMPF(791811,Y,0),U,3) I Z1,$D(^RMPF(791810.1,RMPFTYP,101,""B"",Z1))"
77 S DIC("S")="I Y'=1"
78SE0 S DIC=791811,DIC(0)="AEQM",DIC("A")="SELECT ITEM: " W !
79 D ^DIC S:X[U RMPFOUT="" K DIC G SELECTE:Y=-1 S RMPFIT=+Y
80 I RMPFST<3,$D(^RMPF(791811,RMPFIT,"I")),$P(^("I"),U,1),"ILHXEUNTVG"'[RMPFHAT W !!,"*** THIS LINE ITEM HAS BEEN INACTIVATED FOR NEW ORDERS ***" K RMPFIT G SELECT
81SE1 S RMPFITP=$P(Y,U,2)
82SELECTE K DIC,X,Y,SL,%,%Y,DISYS,Z1 Q
83 ;
84DELETE ;;Delete a line item
85 ;; input: RMPFX,RMPFY
86 ;;output: None
87 W !!,"Are you sure you want to delete this item? NO// " D READ
88 G DELETEE:$D(RMPFOUT)
89DEL1 I $D(RMPFQUT) W !!,"If you enter a <Y> the item will be permanently deleted from this order.",!,"If you enter a <N> or <RETURN> the item will be retained on the order." G DELETE
90 S:Y="" Y="N" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G DEL1
91 G DELETEE:Y="N" S DIE="^RMPF(791810,"_RMPFX_",101,",DA=RMPFY
92 S DA(1)=RMPFX,DR=".01////@" D ^DIE
93DELETEE K X,Y,DIE,DA,DR,DI,DQ,D0,D,%,DIC,RMPFY Q
94READ K RMPFOUT,RMPFQUT
95 R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
96 I Y?1"^".E S (RMPFOUT,Y)="" Q
97 S:Y?1"?".E (RMPFQUT,Y)=""
98 Q
Note: See TracBrowser for help on using the repository browser.