source: WorldVistAEHR/trunk/r/REMOTE_ORDER_ENTRY_SYSTEM-RMPF-RMPJ/RMPFET6.m@ 923

RMPFET6 ;DDC/KAW-EDIT LINE ITEM INFORMATION [ 05/12/98  1:45 PM ]
 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**20**;MAY 30, 1995
 ;; input: RMPFX,RMPFTP,RMPFTYP,RMPFHAT,RMPFST,DFN (if patient order)
 ;;output: None
 Q:'$D(RMPFX)  S X=$G(^RMPF(791810,RMPFX,0)) Q:X=""
START K RMPFMD,RMPFY D ARRAY^RMPFDT2
 S (X,RMPFMC)=0 F  S X=$O(RMPFO(X)) Q:'X  S RMPFMC=RMPFMC+1
 I 'RMPFMC S Y1="A" G ST1
 D:RMPFTP="P" PAT^RMPFUTL
 W @IOF,!?33,"ITEMS ORDERED" D @("HEAD"_RMPFTP_"^RMPFDT1")
 W !! D ^RMPFDT2 K RMPFY
 D ^RMPFET62 G END:$D(RMPFOUT),END:'$D(Y1)
 I "Dd"[Y1,$D(RMPFY) D DELETE G END
ST1 I "Aa"[Y1 D ADD G END:$D(RMPFOUT),END:'$D(RMPFY)
 D EDIT G END:$D(RMPFOUT),START
END K CX,SX,RMPFDOB,RMPFDOD,RMPFMC,RMPFMD,RMPFNAM,RMPFO,RMPFSSN,Y1
 K RMPFSTR0,RMPFSTR2,RMPFSTR3 Q
 ;
ADD ;;Add a new line item
 ;; input: RMPFX,RMPFTYP,RMPFHAT,RMPFST
 ;;output: RMPFY,RMPFIT,RMPFITP
 K RMPFIT
 D SELECT G ADDE:$D(RMPFOUT),ADDE:'$D(RMPFIT)
ADD1 I '$D(^RMPF(791810,RMPFX,101,0)) S ^RMPF(791810,RMPFX,101,0)="^791810.0101P"
 S %DT="T",X="NOW" D ^%DT
 S DIC="^RMPF(791810,"_RMPFX_",101,",(DA,DA(1))=RMPFX,X=RMPFIT
 S DIC(0)="L",DLAYGO=791810,DIC("DR")=".15////O;.17////"_Y_";.18///1;.19////O;.2////1"
 S:RMPFIT=1 DIC("DR")=DIC("DR")_";2.01;2.02"
 K DD,DO D FILE^DICN
 I Y=-1 W !!,"*** UNABLE TO ADD LINE ITEM ***" G ADDE
 S RMPFY=+Y I RMPFIT=1 D  G ADDE:'$D(RMPFY)
 .Q:RMPFHAT="E"
 .I $D(^RMPF(791810,RMPFX,101,RMPFY,2)),$P(^(2),U,2)'="" Q
 .S DA=RMPFY,DIK="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX
 .D ^DIK K RMPFY
 G ADDE:'$D(RMPFY)
 S DIE="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX,DA=RMPFY
 S DR=".16////"_RMPFY D ^DIE
 K RMPF F I=5,10,11 S RMPF(I)=""
ADDE K DI,DIE,DQ,DR,DIC,DIK,X,Y,DA,DD,D0,RMPF,ZY,ZZ,%,D,%DT,I Q
 ;
EDIT ;;Edit information for a line item
 ;; input: RMPFX,RMPFY,Y1,RMPFTYP,RMPFHAT,RMPFST
 ;;output: None
 Q:'$D(RMPFX)!'$D(RMPFY)
 S RMPFSTO=$P(^RMPF(791810,RMPFX,101,RMPFY,0),U,18) S:RMPFSTO="" RMPFSTO=1
 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
 I RMPFSTO=6!(RMPFSTO=7)!(RMPFSTO=10) D CLEAR^RMPFET61 G EDITE:'$D(RMPFSTO)
 D PRIOR^RMPFET61 G ED1:"Aa"[Y1
 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)
 I RMPFHAT="E" S RMPFIT=1 G ED1
 D SELECT G EDITE:$D(RMPFOUT),EDITE:'$D(RMPFIT)
ED1 S RMPFPGP=$P(^RMPF(791811,RMPFIT,0),U,3) I RMPFPGP,$D(^RMPF(791811.1,RMPFPGP,0)) S RMPFPGP=$P(^(0),U,2)
 S DR=$P($G(^RMPF(791810.1,RMPFTYP,1)),U,1)
 I RMPFTYP=2 I $D(^RMPF(791811,RMPFIT,0)) I $P(^(0),"^",1)["REMOTE" D
 .S $P(DR,";",1)=$P(DR,";",1)_"////^S X=""R"""
 S ST=".01////"_RMPFIT I RMPFIT=1 S ST=ST_";2.01;2.02"
 S DR=$S(DR'="":ST_";"_DR,1:ST_RMPFIT)
 I RMPFIT'=$P(^RMPF(791810,RMPFX,101,RMPFY,0),U,1) K ^RMPF(791810,RMPFX,101,RMPFY,102)
 S DIE="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX,DA=RMPFY D ^DIE
 D ^RMPFET61
 I "CS"[RMPFHAT D
 .S RMPFY=9999 D PRIOR^RMPFET61,^RMPFET9
 .I $D(RMPFY1) S RMPFY=RMPFY1 D ^RMPFET61
EDITE K X,Y,Y1,%Y,D0,DI,DIE,DQ,DR,RMPFTF,RMPFRE,RMPFIT,RMPFITP,RMPFO,RMPFPGP
 K %,CX,D,D1,DA,DIC,DLAYGO,RMPFSTO,I,DISYS,RMPFSTR0,RMPFSTR2,RMPFSTR3,ST Q
 ;
SELECT ;;Select a line item from 791811
 ;; input: RMPFTYP,RMPFST
 ;;output: RMPFIT,RMPFITP
 S SL=$P(^RMPF(791810.1,RMPFTYP,0),U,9)
 I SL=2 S RMPFIT=1,RMPFITP=$P(^RMPF(791811,1,0),U,1) G SELECTE
 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
 I $O(^RMPF(791810.1,RMPFTYP,101,"B",0)) D  G SE0
 .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))"
 .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))"
 S DIC("S")="I Y'=1"
SE0 S DIC=791811,DIC(0)="AEQM",DIC("A")="SELECT ITEM: " W !
 D ^DIC S:X[U RMPFOUT="" K DIC G SELECTE:Y=-1 S RMPFIT=+Y
 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
SE1 S RMPFITP=$P(Y,U,2)
SELECTE K DIC,X,Y,SL,%,%Y,DISYS,Z1 Q
 ;
DELETE ;;Delete a line item
 ;; input: RMPFX,RMPFY
 ;;output: None
 W !!,"Are you sure you want to delete this item? NO// " D READ
 G DELETEE:$D(RMPFOUT)
DEL1 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
 S:Y="" Y="N" S Y=$E(Y,1) I "YyNn"'[Y S RMPFQUT="" G DEL1
 G DELETEE:Y="N" S DIE="^RMPF(791810,"_RMPFX_",101,",DA=RMPFY
 S DA(1)=RMPFX,DR=".01////@" D ^DIE
DELETEE K X,Y,DIE,DA,DR,DI,DQ,D0,D,%,DIC,RMPFY 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