PRCPHLP ;WISC/CC - PROCESS HL7 TXN ON REFILLS AND ORDER POSTING; 4/00
V ;;5.1;IFCAP;**1**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
N DIC,DIE,DR,ERR,I,J,X,XMB
N NUMBER,ORDERDA,PRIM
N PRCPAMT,PRCPHL,PRCPHLPO,PRCPITEM,PRCPLEFT,PRCPOC,PRCPORD
N PRCPSEC,PRCPSECN,PRCPSET,PRCPSITE,PRCPTIME,PRCPUSER
;
S I=1
I HL("MTN")'="ORM" S ERR="1B" G ERR ; wrong message name
X HLNEXT I HLQUIT'>0 S ERR="1A" G ERR ; missing segments
S PRCPHL(1)=HLNODE,I=2
;
X HLNEXT I HLQUIT'>0 S ERR="1A" G ERR ; missing segments
S PRCPHL(I)=HLNODE,J=0,I=I+1
I $$FLD^HLCSUTL(HLNODE,1)'="ORC" S ERR="1A" G ERR ; wrong segment name
D ORC I $D(ERR) G ERR
;
X HLNEXT I HLQUIT'>0,PRCPOC="OF" S ERR="1A" G ERR ; missing segments
; Order completion transactions will only have an ORC segment
I HLQUIT'>0,PRCPOC="FU" G PROCESS
S PRCPHL(I)=HLNODE,I=I+1,J=0
I PRCPOC="FU" S ERR="1A" G ERR ; too many segments for order class code
I $$FLD^HLCSUTL(HLNODE,1)'="RQD" S ERR="1A" G ERR ; wrong segment name
;
; RQD SEGMENT
RQD S PRCPITEM=$$FLD^HLCSUTL(HLNODE,5) ; ID~NAME
S PRCPAMT=$$FLD^HLCSUTL(HLNODE,6) ; REFILL QTY - restock issue units
;
; check item info
I +PRCPITEM'=$P(PRCPITEM,$E(HL("ECH"),1),1)!(+PRCPITEM=0) S ERR="6E" G ERR ; item number invalid
I '$D(^PRCP(445.3,ORDERDA,1,$P(PRCPITEM,$E(HL("ECH"),1),1))) S ERR="6A" G ERR ; item not on order
I '$D(^PRCP(445,$P(^PRCP(445.3,ORDERDA,0),"^",2),1,$P(PRCPITEM,$E(HL("ECH"),1),1))) S ERR="6B" G ERR ; item not in primary
I '$D(^PRCP(445,PRCPSECN,1,$P(PRCPITEM,$E(HL("ECH"),1),1))) S ERR="6C" G ERR
I $P(^PRCP(445,PRCPSECN,1,$P(PRCPITEM,$E(HL("ECH"),1),1),0),"^",9)'>0 S ERR="6D" G ERR ; is item a supply station item
I $P($G(^PRC(441,$P(PRCPITEM,$E(HL("ECH"),1)),0)),"^",6)="S" S ERR="6G" G ERR ; case cart/ik
;
; verify amount
I +PRCPAMT'=PRCPAMT!(PRCPAMT>999999)!(PRCPAMT<-999999) S ERR=4 G ERR
;
X HLNEXT I HLQUIT'>0 S ERR="1A" G ERR ; missing segments
S PRCPHL(I)=HLNODE,J=0,I=I+1
I $$FLD^HLCSUTL(HLNODE,1)'="NTE" S ERR="1A" G ERR ; wrong segment name
;
; READ NTE SEGMENT
NTE S PRCPLEFT=$$FLD^HLCSUTL(HLNODE,4)
I +PRCPLEFT'=PRCPLEFT!(PRCPLEFT>999999)!(PRCPLEFT<-999999) S ERR=5 G ERR
;
X HLNEXT I HLQUIT'>0 G PROCESS
S PRCPHL(I)=HLNODE,I=I+1,J=0
S ERR="1A" G ERR ; too many segments
G Q
;
; ORC SEGMENT
ORC S PRCPOC=$$FLD^HLCSUTL(HLNODE,2)
S PRCPSEC=$$FLD^HLCSUTL(HLNODE,5)
S PRCPORD=$$FLD^HLCSUTL(HLNODE,3)
;
I PRCPOC'="OF",PRCPOC'="FU" S ERR="1C" Q ; order control wrong
;
; find site and IP ien
S PRCPSEC=$P(PRCPSEC,$E(HL("ECH"),1),2)
I PRCPSEC']"" S ERR="3E" G ERR
S PRCPSITE=$P(PRCPSEC,"-",1)
I PRCPSITE']"" S ERR="3E" Q ; site missing
I '$D(^PRC(411,PRCPSITE,0)) S ERR="3D" Q ; wrong site
S DIC="^PRCP(445,",DIC(0)="X",X=PRCPSEC,PRCPPRIV=1
D ^DIC K DIC
I Y=-1 S ERR="3A" Q ; secondary not in GIP
S PRCPSECN=$P(Y,"^",1)
I $P(^PRCP(445,PRCPSECN,0),"^",3)'="S" S ERR="3B" Q ; not a secondary
;
S PRIM=$O(^PRCP(445,"AB",PRCPSECN,""))
I PRIM']"" S ERR="2A" Q
; get internal order number
I PRCPORD]"" D I $D(ERR) Q
. S DIC="^PRCP(445.3,",DIC(0)="X",X=PRCPORD,PRCPPRIV=1
. S DIC("S")="I $P(^(0),U,2)="_PRIM
. D ^DIC K DIC
. I Y=-1 S ERR="2A" Q ; order not in GIP
. S ORDERDA=$P(Y,"^",1)
. I $P(^PRCP(445.3,ORDERDA,0),"^",6)="P" S ERR="2B" Q ; order is posted
. I $P(^PRCP(445.3,ORDERDA,0),"^",10)']"" S ERR="2C" Q ; order not to be completed by supply station
. I $P(^PRCP(445.3,ORDERDA,0),"^",3)'=PRCPSECN S ERR="3C" Q ; sec on order differs
I HL("MTN")="ORM",PRCPORD']"" S ERR="2D" Q ; order number missing
;
S PRCPTIME=$$FLD^HLCSUTL(HLNODE,10)
S PRCPTIME=$$FMDATE^HLFNC(PRCPTIME)
S PRCPUSER=$$FLD^HLCSUTL(HLNODE,11)
S PRCPUSER=$P(PRCPUSER,$E(HL("ECH"),1),2)
S PRCPUSER=$$FMNAME^HLFNC(PRCPUSER,$E(HL("ECH"),1))
Q
;
;
ERR S NUMBER=ERR
I '$D(PRCPSECN) S PRCPSECN=0
S PRCPHLPO("ORDER")="" I $D(PRCPORD) S PRCPHLPO("ORDER")=PRCPORD
S PRCPHLPO("SIPNAME")="AN UNKNOWN INVENTORY POINT"
I $D(PRCPSEC),PRCPSEC]"" S PRCPHLPO("SIPNAME")=PRCPSEC
S PRCPHLPO("ITEM")=""
I $D(PRCPITEM) S PRCPHLPO("ITEM")=$P(PRCPITEM,$E(HL("ECH"),1),1)
S PRCPHLPO("NAME")=""
I $D(PRCPITEM) S PRCPHLPO("NAME")=$P(PRCPITEM,$E(HL("ECH"),1),2)
S PRCPHLPO("QTY")="" I $D(PRCPAMT) S PRCPHLPO("QTY")=PRCPAMT
S PRCPHLPO("LEFT")="" I $D(PRCPLEFT) S PRCPHLPO("LEFT")=PRCPLEFT
S PRCPHLPO("TYPE")=PRCPOC
D ERR^PRCPHLM0(ERR,"PRCP_BAD_ORDER",PRCPSECN,.PRCPHLPO,HLMTIENS_"."_HLMTIEN,.PRCPHL)
G UNLOCK
;
;
PROCESS N %,%H,%I,N,PRCPTXN,PRCPTXNT,PRCPMGTP,PRCPHL7,PRCPITNM,CNT,DA,DIC,DIE,DLAYGO,DR,T,X,Y
S X="PRCPHL7TXN",CNT=0
PROCES0 I $D(^PRCS(410.1,"B",X)) D I $D(ERR) S CNT=CNT+1 G PROCES0:CNT<10 S CNT=0 G ERR
. S N="",N=$O(^PRCS(410.1,"B",X,N)),DA=N
. L +^PRCS(410.1,DA):15 I $T=0 S ERR=198 Q
. S T=$P(^PRCS(410.1,N,0),"^",2)+1 S:T<1 T=1
. S $P(^PRCS(410.1,DA,0),"^",2)=+T
. S $P(^PRCS(410.1,DA,0),"^",3)=DT
. L -^PRCS(410.1,DA)
I '$D(^PRCS(410.1,"B",X)) D I $D(ERR) S CNT=CNT+1 G PROCES0:CNT<10 S CNT=0 G ERR
. S T=1,DLAYGO=410.1,DIC="^PRCS(410.1,",DIC(0)="FLXZ"
. D ^DIC K DLAYGO I Y<0 S ERR=199
. S DA=+Y
. L +^PRCS(410.1,DA):15 I $T=0 S ERR=198 Q
. S $P(^PRCS(410.1,DA,0),"^",2)=+T
. S $P(^PRCS(410.1,DA,0),"^",3)=DT
. L -^PRCS(410.1,DA)
;
PROCES1 S CNT=0,X=T
S DIC="^PRCP(447.1,"
S DIC(0)="L"
S DLAYGO=447.1
D ^DIC K DIC
I Y=-1 S ERR=100,CNT=CNT+1 G PROCES1:CNT<10,ERR
I $P(Y,"^",3)'=1 S ERR=101 G ERR
S (DA,PRCPTXN)=Y+0
L +^PRCP(447.1,DA):3 I $T=0 S ERR=102 D UNLOCK G ERR
S DIE="^PRCP(447.1,"
S DA=PRCPTXN
D NOW^%DTC
S PRCPTXNT=%
S PRCPHL7=HLMTIENS_"."_HLMTIEN
S PRCPMGTP=HL("MTN")_HL("ETN")
S DR="1///^S X=PRCPSITE;2///^S X=PRCPSECN;3///^S X=PRCPTXNT;4///^S X=PRCPMGTP;5///^S X=PRCPHL7;6////^S X=ORDERDA;8///^S X=PRCPTIME;10///^S X=PRCPUSER"
I PRCPOC="FU" S DR=DR_";11///^S X=PRCPOC"
D ^DIE
K DIE,DR
I PRCPOC="FU" G UNLOCK
S DIC="^PRCP(447.1,"_PRCPTXN_",1,"
S DA(1)=PRCPTXN
S DIC(0)="L"
S DLAYGO=447.1
S DIC("P")=$P(^DD(447.1,7,0),"^",2)
S X=$P(PRCPITEM,$E(HL("ECH"),1),1)
S PRCPSET="I 1" ; over rides screen to omit finding case carts/IK's
D ^DIC K DIC,DA,DLAYGO
I Y=-1 S ERR=110 D UNLOCK G ERR
I $P(Y,"^",3)'=1 S ERR=111 D UNLOCK G ERR
S DIE="^PRCP(447.1,"_PRCPTXN_",1,"
S DA=+Y
S PRCPITNM=$P(PRCPITEM,$E(HL("ECH"),1),2)
S DR="1///^S X=PRCPLEFT;2///^S X=PRCPAMT;3///^S X=PRCPITNM"
D ^DIE K DIE,DIC,DR
UNLOCK I $D(ERR),$D(PRCPTXN),PRCPTXN>0 S DA=PRCPTXN,DIK="^PRCP(447.1," D ^DIK
I $G(PRCPTXN) L -^PRCP(447.1,PRCPTXN)
Q Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPHLP 6578 printed Dec 13, 2024@02:13:54 Page 2
PRCPHLP ;WISC/CC - PROCESS HL7 TXN ON REFILLS AND ORDER POSTING; 4/00
V ;;5.1;IFCAP;**1**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
+3 NEW DIC,DIE,DR,ERR,I,J,X,XMB
+4 NEW NUMBER,ORDERDA,PRIM
+5 NEW PRCPAMT,PRCPHL,PRCPHLPO,PRCPITEM,PRCPLEFT,PRCPOC,PRCPORD
+6 NEW PRCPSEC,PRCPSECN,PRCPSET,PRCPSITE,PRCPTIME,PRCPUSER
+7 ;
+8 SET I=1
+9 ; wrong message name
IF HL("MTN")'="ORM"
SET ERR="1B"
GOTO ERR
+10 ; missing segments
XECUTE HLNEXT
IF HLQUIT'>0
SET ERR="1A"
GOTO ERR
+11 SET PRCPHL(1)=HLNODE
SET I=2
+12 ;
+13 ; missing segments
XECUTE HLNEXT
IF HLQUIT'>0
SET ERR="1A"
GOTO ERR
+14 SET PRCPHL(I)=HLNODE
SET J=0
SET I=I+1
+15 ; wrong segment name
IF $$FLD^HLCSUTL(HLNODE,1)'="ORC"
SET ERR="1A"
GOTO ERR
+16 DO ORC
IF $DATA(ERR)
GOTO ERR
+17 ;
+18 ; missing segments
XECUTE HLNEXT
IF HLQUIT'>0
IF PRCPOC="OF"
SET ERR="1A"
GOTO ERR
+19 ; Order completion transactions will only have an ORC segment
+20 IF HLQUIT'>0
IF PRCPOC="FU"
GOTO PROCESS
+21 SET PRCPHL(I)=HLNODE
SET I=I+1
SET J=0
+22 ; too many segments for order class code
IF PRCPOC="FU"
SET ERR="1A"
GOTO ERR
+23 ; wrong segment name
IF $$FLD^HLCSUTL(HLNODE,1)'="RQD"
SET ERR="1A"
GOTO ERR
+24 ;
+25 ; RQD SEGMENT
RQD ; ID~NAME
SET PRCPITEM=$$FLD^HLCSUTL(HLNODE,5)
+1 ; REFILL QTY - restock issue units
SET PRCPAMT=$$FLD^HLCSUTL(HLNODE,6)
+2 ;
+3 ; check item info
+4 ; item number invalid
IF +PRCPITEM'=$PIECE(PRCPITEM,$EXTRACT(HL("ECH"),1),1)!(+PRCPITEM=0)
SET ERR="6E"
GOTO ERR
+5 ; item not on order
IF '$DATA(^PRCP(445.3,ORDERDA,1,$PIECE(PRCPITEM,$EXTRACT(HL("ECH"),1),1)))
SET ERR="6A"
GOTO ERR
+6 ; item not in primary
IF '$DATA(^PRCP(445,$PIECE(^PRCP(445.3,ORDERDA,0),"^",2),1,$PIECE(PRCPITEM,$EXTRACT(HL("ECH"),1),1)))
SET ERR="6B"
GOTO ERR
+7 IF '$DATA(^PRCP(445,PRCPSECN,1,$PIECE(PRCPITEM,$EXTRACT(HL("ECH"),1),1)))
SET ERR="6C"
GOTO ERR
+8 ; is item a supply station item
IF $PIECE(^PRCP(445,PRCPSECN,1,$PIECE(PRCPITEM,$EXTRACT(HL("ECH"),1),1),0),"^",9)'>0
SET ERR="6D"
GOTO ERR
+9 ; case cart/ik
IF $PIECE($GET(^PRC(441,$PIECE(PRCPITEM,$EXTRACT(HL("ECH"),1)),0)),"^",6)="S"
SET ERR="6G"
GOTO ERR
+10 ;
+11 ; verify amount
+12 IF +PRCPAMT'=PRCPAMT!(PRCPAMT>999999)!(PRCPAMT<-999999)
SET ERR=4
GOTO ERR
+13 ;
+14 ; missing segments
XECUTE HLNEXT
IF HLQUIT'>0
SET ERR="1A"
GOTO ERR
+15 SET PRCPHL(I)=HLNODE
SET J=0
SET I=I+1
+16 ; wrong segment name
IF $$FLD^HLCSUTL(HLNODE,1)'="NTE"
SET ERR="1A"
GOTO ERR
+17 ;
+18 ; READ NTE SEGMENT
NTE SET PRCPLEFT=$$FLD^HLCSUTL(HLNODE,4)
+1 IF +PRCPLEFT'=PRCPLEFT!(PRCPLEFT>999999)!(PRCPLEFT<-999999)
SET ERR=5
GOTO ERR
+2 ;
+3 XECUTE HLNEXT
IF HLQUIT'>0
GOTO PROCESS
+4 SET PRCPHL(I)=HLNODE
SET I=I+1
SET J=0
+5 ; too many segments
SET ERR="1A"
GOTO ERR
+6 GOTO Q
+7 ;
+8 ; ORC SEGMENT
ORC SET PRCPOC=$$FLD^HLCSUTL(HLNODE,2)
+1 SET PRCPSEC=$$FLD^HLCSUTL(HLNODE,5)
+2 SET PRCPORD=$$FLD^HLCSUTL(HLNODE,3)
+3 ;
+4 ; order control wrong
IF PRCPOC'="OF"
IF PRCPOC'="FU"
SET ERR="1C"
QUIT
+5 ;
+6 ; find site and IP ien
+7 SET PRCPSEC=$PIECE(PRCPSEC,$EXTRACT(HL("ECH"),1),2)
+8 IF PRCPSEC']""
SET ERR="3E"
GOTO ERR
+9 SET PRCPSITE=$PIECE(PRCPSEC,"-",1)
+10 ; site missing
IF PRCPSITE']""
SET ERR="3E"
QUIT
+11 ; wrong site
IF '$DATA(^PRC(411,PRCPSITE,0))
SET ERR="3D"
QUIT
+12 SET DIC="^PRCP(445,"
SET DIC(0)="X"
SET X=PRCPSEC
SET PRCPPRIV=1
+13 DO ^DIC
KILL DIC
+14 ; secondary not in GIP
IF Y=-1
SET ERR="3A"
QUIT
+15 SET PRCPSECN=$PIECE(Y,"^",1)
+16 ; not a secondary
IF $PIECE(^PRCP(445,PRCPSECN,0),"^",3)'="S"
SET ERR="3B"
QUIT
+17 ;
+18 SET PRIM=$ORDER(^PRCP(445,"AB",PRCPSECN,""))
+19 IF PRIM']""
SET ERR="2A"
QUIT
+20 ; get internal order number
+21 IF PRCPORD]""
Begin DoDot:1
+22 SET DIC="^PRCP(445.3,"
SET DIC(0)="X"
SET X=PRCPORD
SET PRCPPRIV=1
+23 SET DIC("S")="I $P(^(0),U,2)="_PRIM
+24 DO ^DIC
KILL DIC
+25 ; order not in GIP
IF Y=-1
SET ERR="2A"
QUIT
+26 SET ORDERDA=$PIECE(Y,"^",1)
+27 ; order is posted
IF $PIECE(^PRCP(445.3,ORDERDA,0),"^",6)="P"
SET ERR="2B"
QUIT
+28 ; order not to be completed by supply station
IF $PIECE(^PRCP(445.3,ORDERDA,0),"^",10)']""
SET ERR="2C"
QUIT
+29 ; sec on order differs
IF $PIECE(^PRCP(445.3,ORDERDA,0),"^",3)'=PRCPSECN
SET ERR="3C"
QUIT
End DoDot:1
IF $DATA(ERR)
QUIT
+30 ; order number missing
IF HL("MTN")="ORM"
IF PRCPORD']""
SET ERR="2D"
QUIT
+31 ;
+32 SET PRCPTIME=$$FLD^HLCSUTL(HLNODE,10)
+33 SET PRCPTIME=$$FMDATE^HLFNC(PRCPTIME)
+34 SET PRCPUSER=$$FLD^HLCSUTL(HLNODE,11)
+35 SET PRCPUSER=$PIECE(PRCPUSER,$EXTRACT(HL("ECH"),1),2)
+36 SET PRCPUSER=$$FMNAME^HLFNC(PRCPUSER,$EXTRACT(HL("ECH"),1))
+37 QUIT
+38 ;
+39 ;
ERR SET NUMBER=ERR
+1 IF '$DATA(PRCPSECN)
SET PRCPSECN=0
+2 SET PRCPHLPO("ORDER")=""
IF $DATA(PRCPORD)
SET PRCPHLPO("ORDER")=PRCPORD
+3 SET PRCPHLPO("SIPNAME")="AN UNKNOWN INVENTORY POINT"
+4 IF $DATA(PRCPSEC)
IF PRCPSEC]""
SET PRCPHLPO("SIPNAME")=PRCPSEC
+5 SET PRCPHLPO("ITEM")=""
+6 IF $DATA(PRCPITEM)
SET PRCPHLPO("ITEM")=$PIECE(PRCPITEM,$EXTRACT(HL("ECH"),1),1)
+7 SET PRCPHLPO("NAME")=""
+8 IF $DATA(PRCPITEM)
SET PRCPHLPO("NAME")=$PIECE(PRCPITEM,$EXTRACT(HL("ECH"),1),2)
+9 SET PRCPHLPO("QTY")=""
IF $DATA(PRCPAMT)
SET PRCPHLPO("QTY")=PRCPAMT
+10 SET PRCPHLPO("LEFT")=""
IF $DATA(PRCPLEFT)
SET PRCPHLPO("LEFT")=PRCPLEFT
+11 SET PRCPHLPO("TYPE")=PRCPOC
+12 DO ERR^PRCPHLM0(ERR,"PRCP_BAD_ORDER",PRCPSECN,.PRCPHLPO,HLMTIENS_"."_HLMTIEN,.PRCPHL)
+13 GOTO UNLOCK
+14 ;
+15 ;
PROCESS NEW %,%H,%I,N,PRCPTXN,PRCPTXNT,PRCPMGTP,PRCPHL7,PRCPITNM,CNT,DA,DIC,DIE,DLAYGO,DR,T,X,Y
+1 SET X="PRCPHL7TXN"
SET CNT=0
PROCES0 IF $DATA(^PRCS(410.1,"B",X))
Begin DoDot:1
+1 SET N=""
SET N=$ORDER(^PRCS(410.1,"B",X,N))
SET DA=N
+2 LOCK +^PRCS(410.1,DA):15
IF $TEST=0
SET ERR=198
QUIT
+3 SET T=$PIECE(^PRCS(410.1,N,0),"^",2)+1
if T<1
SET T=1
+4 SET $PIECE(^PRCS(410.1,DA,0),"^",2)=+T
+5 SET $PIECE(^PRCS(410.1,DA,0),"^",3)=DT
+6 LOCK -^PRCS(410.1,DA)
End DoDot:1
IF $DATA(ERR)
SET CNT=CNT+1
if CNT<10
GOTO PROCES0
SET CNT=0
GOTO ERR
+7 IF '$DATA(^PRCS(410.1,"B",X))
Begin DoDot:1
+8 SET T=1
SET DLAYGO=410.1
SET DIC="^PRCS(410.1,"
SET DIC(0)="FLXZ"
+9 DO ^DIC
KILL DLAYGO
IF Y<0
SET ERR=199
+10 SET DA=+Y
+11 LOCK +^PRCS(410.1,DA):15
IF $TEST=0
SET ERR=198
QUIT
+12 SET $PIECE(^PRCS(410.1,DA,0),"^",2)=+T
+13 SET $PIECE(^PRCS(410.1,DA,0),"^",3)=DT
+14 LOCK -^PRCS(410.1,DA)
End DoDot:1
IF $DATA(ERR)
SET CNT=CNT+1
if CNT<10
GOTO PROCES0
SET CNT=0
GOTO ERR
+15 ;
PROCES1 SET CNT=0
SET X=T
+1 SET DIC="^PRCP(447.1,"
+2 SET DIC(0)="L"
+3 SET DLAYGO=447.1
+4 DO ^DIC
KILL DIC
+5 IF Y=-1
SET ERR=100
SET CNT=CNT+1
if CNT<10
GOTO PROCES1
GOTO ERR
+6 IF $PIECE(Y,"^",3)'=1
SET ERR=101
GOTO ERR
+7 SET (DA,PRCPTXN)=Y+0
+8 LOCK +^PRCP(447.1,DA):3
IF $TEST=0
SET ERR=102
DO UNLOCK
GOTO ERR
+9 SET DIE="^PRCP(447.1,"
+10 SET DA=PRCPTXN
+11 DO NOW^%DTC
+12 SET PRCPTXNT=%
+13 SET PRCPHL7=HLMTIENS_"."_HLMTIEN
+14 SET PRCPMGTP=HL("MTN")_HL("ETN")
+15 SET DR="1///^S X=PRCPSITE;2///^S X=PRCPSECN;3///^S X=PRCPTXNT;4///^S X=PRCPMGTP;5///^S X=PRCPHL7;6////^S X=ORDERDA;8///^S X=PRCPTIME;10///^S X=PRCPUSER"
+16 IF PRCPOC="FU"
SET DR=DR_";11///^S X=PRCPOC"
+17 DO ^DIE
+18 KILL DIE,DR
+19 IF PRCPOC="FU"
GOTO UNLOCK
+20 SET DIC="^PRCP(447.1,"_PRCPTXN_",1,"
+21 SET DA(1)=PRCPTXN
+22 SET DIC(0)="L"
+23 SET DLAYGO=447.1
+24 SET DIC("P")=$PIECE(^DD(447.1,7,0),"^",2)
+25 SET X=$PIECE(PRCPITEM,$EXTRACT(HL("ECH"),1),1)
+26 ; over rides screen to omit finding case carts/IK's
SET PRCPSET="I 1"
+27 DO ^DIC
KILL DIC,DA,DLAYGO
+28 IF Y=-1
SET ERR=110
DO UNLOCK
GOTO ERR
+29 IF $PIECE(Y,"^",3)'=1
SET ERR=111
DO UNLOCK
GOTO ERR
+30 SET DIE="^PRCP(447.1,"_PRCPTXN_",1,"
+31 SET DA=+Y
+32 SET PRCPITNM=$PIECE(PRCPITEM,$EXTRACT(HL("ECH"),1),2)
+33 SET DR="1///^S X=PRCPLEFT;2///^S X=PRCPAMT;3///^S X=PRCPITNM"
+34 DO ^DIE
KILL DIE,DIC,DR
UNLOCK IF $DATA(ERR)
IF $DATA(PRCPTXN)
IF PRCPTXN>0
SET DA=PRCPTXN
SET DIK="^PRCP(447.1,"
DO ^DIK
+1 IF $GET(PRCPTXN)
LOCK -^PRCP(447.1,PRCPTXN)
Q QUIT
