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