- 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 Apr 23, 2025@18:50:52 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
