PRCPHLQ ;WISC/CC - PROCESS HL7 QOH TRANSACTIONS FROM SUPPLY STATION; 4/00
V ;;5.1;IFCAP;**1**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
N DA,DIC,DIE,DIK,DLAYGO,DR,ERR,I,J,LNCNT,NUMBER,X,Y,WARN
N PRCP7,PRCPDATA,PRCPHL,PRCPITEM,PRCPLEFT,PRCPOC,PRCPSEC,PRCPSECN
N PRCPSITE,PRCPTIME,PRCPTXN,PRCPUSER
S PRCPTXN=0,PRCPSEC="",LNCNT=1
;
;
OSR I HL("MTN")'="OSR" S ERR="1B" G ERR ; wrong message name
X HLNEXT I HLQUIT'>0 S ERR="1A" G ERR ; missing MSH segment
S PRCPHL(LNCNT)=HLNODE,LNCNT=LNCNT+1
X HLNEXT I HLQUIT'>0 S ERR="1A" G ERR ; missing segments
S PRCPHL(LNCNT)=HLNODE,J=0,LNCNT=LNCNT+1,I=1
S X=$$FLD^HLCSUTL(HLNODE,1)
I X'="MSA" S ERR="1A" G ERR ; wrong segment name
S X=$$FLD^HLCSUTL(HLNODE,2)
I X="AE"!(X="AR") S ERR="1F" G ERR ; supply station trouble
;
X HLNEXT I HLQUIT'>0 S ERR="1A" G ERR ; missing segments
S PRCPHL(LNCNT)=HLNODE,J=0,LNCNT=LNCNT+1,I=1
S X=$$FLD^HLCSUTL(HLNODE,1)
;
F G:$D(ERR) ERR Q:X'="ERR" D ; can build user message from ERR segs
. X HLNEXT I HLQUIT'>0 S ERR="1A",X="OUT" Q ; missing segments
. S PRCPHL(LNCNT)=HLNODE,J=0,LNCNT=LNCNT+1,I=1
. S X=$$FLD^HLCSUTL(HLNODE,1)
;
I X'="QRD" S ERR="1A" G ERR ; wrong segment name
;
QRD ; QRD SEGMENT
I $$FLD^HLCSUTL(HLNODE,3)'="R"!($$FLD^HLCSUTL(HLNODE,4)'="D")!($$FLD^HLCSUTL(HLNODE,5)'="QOH")!($$FLD^HLCSUTL(HLNODE,10)'="STA") S ERR="1E" G ERR
S J=$$FLD^HLCSUTL(HLNODE,13) I J]"",J'="S" S ERR="1E" G ERR
;
X HLNEXT I HLQUIT'>0 S ERR="1A" G ERR ; missing segments
S PRCPHL(LNCNT)=HLNODE,J=0,LNCNT=LNCNT+1,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 S ERR="1A" G ERR ; missing segments
;
LOOP S PRCPHL(LNCNT)=HLNODE,J=0,LNCNT=LNCNT+1,I=1
I $$FLD^HLCSUTL(HLNODE,1)'="NTE" S ERR="1A" G ERR ; wrong segment name
NTE ; READ NTE SEGMENT
S PRCPDATA=$$FLD^HLCSUTL(HLNODE,4) ; ID~NAME~QTY
S PRCPITEM=$P(PRCPDATA,$E(HL("ECH"),1),1,2)
I $P(PRCPITEM,$E(HL("ECH"),1),1)'=+PRCPITEM!(+PRCPITEM=0) D WARN X HLNEXT G Q:HLQUIT'>0 K WARN G LOOP ; item number invalid
I '$D(^PRC(441,+PRCPITEM,0)) D WARN X HLNEXT G Q:HLQUIT'>0 K WARN G LOOP ; item number not in file 441
; 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
S PRCPLEFT=$P(PRCPDATA,$E(HL("ECH"),1),3)
I +PRCPLEFT'=PRCPLEFT!(PRCPLEFT>999999)!(PRCPLEFT<-999999) S ERR=5 G ERR
D PROCESS I $D(ERR) G ERR
;
X HLNEXT I HLQUIT'>0 G Q
G LOOP
;
; ORC SEGMENT
ORC S PRCPOC=$$FLD^HLCSUTL(HLNODE,2)
S PRCPSEC=$$FLD^HLCSUTL(HLNODE,5)
;
I PRCPOC'="OK" S ERR="1C" Q ; order control wrong
;
; get site and IP information
I PRCPSEC']"" S ERR="3A" Q
S PRCPSEC=$P(PRCPSEC,$E(HL("ECH"),1),2)
S PRCPSITE=$P(PRCPSEC,"-",1)
I PRCPSITE']"" S ERR="3E" Q
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 PRCPSECN']"" S ERR="3A" Q
I $P(^PRCP(445,PRCPSECN,0),"^",3)'="S" S ERR="3B" Q ; not a secondary
;
S PRCPTIME=$$FLD^HLCSUTL(HLNODE,10)
S PRCPTIME=$$FMDATE^HLFNC(PRCPTIME)
S PRCPUSER=$$FLD^HLCSUTL(HLNODE,11)
S PRCPUSER=$$FMNAME^HLFNC(PRCPUSER)
Q
;
WARN N ITEM,PRCPXMY,XMB,XMDUZ,XMY
D GETUSER^PRCPXTRM(PRCPSECN) Q:'$O(PRCPXMY("")) ; send to secondary inventory point managers
S ITEM=0
F S ITEM=$O(PRCPXMY(ITEM)) Q:ITEM'>0 I PRCPXMY(ITEM)=1 S XMY(ITEM)=""
S XMB(1)=PRCPSEC
S XMB(2)=PRCPITEM
S XMB(3)=HLMTIENS_"."_HLMTIEN
S XMB="PRCP_BAD_ITEM_QOH"
S XMDUZ="SUPPLY STATION INTERFACE"
D EN^XMB
Q
;
PROCESS N %,%H,%I,DA,PRCPHL7,PRCPITNM,PRCPTXNT,PRCPMGTP,DIC,DIE,DR,N,T,X,Y
I 'PRCPTXN D I $D(ERR) Q
. S X="PRCPHL7TXN"
. I $D(^PRCS(410.1,"B",X)) D I $D(ERR) Q
. . S N="",N=$O(^PRCS(410.1,"B",X,N)),DA=N
. . L +^PRCS(410.1,DA):15 I $T=0 S ERR=198
. . S T=$P(^PRCS(410.1,N,0),"^",2)+1 S:T<1 T=1
. I '$D(^PRCS(410.1,"B",X)) D I $D(ERR) Q
. . 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
. S $P(^PRCS(410.1,DA,0),"^",2)=+T
. S $P(^PRCS(410.1,DA,0),"^",3)=DT
. L -^PRCS(410.1,DA)
. ;
. S X=T
. S DIC="^PRCP(447.1,"
. S DIC(0)="L"
. S DLAYGO=447.1
. D ^DIC K DIC,DLAYGO
. I Y=-1 S ERR=100 Q
. I $P(Y,"^",3)'=1 S ERR=101 Q
. S (DA,PRCPTXN)=Y+0
. L +^PRCP(447.1,DA):3 I $T=0 S ERR=102 Q
. S DIE="^PRCP(447.1,"
. S DA=PRCPTXN
. D NOW^%DTC
. S PRCPTXNT=%
. S PRCPMGTP=HL("MTN")_HL("ETN")
. S PRCPHL7=HLMTIENS_"."_HLMTIEN
. S DR="1///^S X=PRCPSITE;2///^S X=PRCPSECN;3///^S X=PRCPTXNT;4///^S X=PRCPMGTP;5///^S X=PRCPHL7;8///^S X=PRCPTIME"
. D ^DIE
. K DIE,DR
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 Q
I $P(Y,"^",3)'=1 S PRCPLEFT=PRCPLEFT+$P($G(^PRCP(447.1,PRCPTXN,1,+Y,0)),"^",2) ; add quantity for an item in different bins
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;3///^S X=PRCPITNM"
D ^DIE K DIC,DIE,DR
Q
;
ERR ;
I $D(ERR) S NUMBER=ERR
I $D(WARN) S NUMBER=WARN
S PRCP7("SIPNAME")="AN UNKNOWN INVENTORY POINT"
I $D(PRCPSEC),PRCPSEC]"" S PRCP7("SIPNAME")=PRCPSEC
I '$D(PRCPSECN) S PRCPSECN=0
S PRCP7("ITEM")=""
I $D(PRCPITEM) S PRCP7("ITEM")=$P(PRCPITEM,$E(HL("ECH"),1),1)
S PRCP7("NAME")=""
I $D(PRCPITEM) S PRCP7("NAME")=$P(PRCPITEM,$E(HL("ECH"),1),2)
S PRCP7("LEFT")="" I $D(PRCPLEFT) S PRCP7("LEFT")=PRCPLEFT
D ERR^PRCPHLM0(NUMBER,"PRCP_BAD_QUERY",PRCPSECN,.PRCP7,HLMTIENS_"."_HLMTIEN,.PRCPHL)
I ERR,PRCPTXN S DA=PRCPTXN,DIK="^PRCP(447.1," D ^DIK
;
Q I PRCPTXN L -^PRCP(447.1,PRCPTXN)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPHLQ 6077 printed Apr 09, 2024@21:17:38 Page 2
PRCPHLQ ;WISC/CC - PROCESS HL7 QOH TRANSACTIONS FROM SUPPLY STATION; 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 DA,DIC,DIE,DIK,DLAYGO,DR,ERR,I,J,LNCNT,NUMBER,X,Y,WARN
+4 NEW PRCP7,PRCPDATA,PRCPHL,PRCPITEM,PRCPLEFT,PRCPOC,PRCPSEC,PRCPSECN
+5 NEW PRCPSITE,PRCPTIME,PRCPTXN,PRCPUSER
+6 SET PRCPTXN=0
SET PRCPSEC=""
SET LNCNT=1
+7 ;
+8 ;
OSR ; wrong message name
IF HL("MTN")'="OSR"
SET ERR="1B"
GOTO ERR
+1 ; missing MSH segment
XECUTE HLNEXT
IF HLQUIT'>0
SET ERR="1A"
GOTO ERR
+2 SET PRCPHL(LNCNT)=HLNODE
SET LNCNT=LNCNT+1
+3 ; missing segments
XECUTE HLNEXT
IF HLQUIT'>0
SET ERR="1A"
GOTO ERR
+4 SET PRCPHL(LNCNT)=HLNODE
SET J=0
SET LNCNT=LNCNT+1
SET I=1
+5 SET X=$$FLD^HLCSUTL(HLNODE,1)
+6 ; wrong segment name
IF X'="MSA"
SET ERR="1A"
GOTO ERR
+7 SET X=$$FLD^HLCSUTL(HLNODE,2)
+8 ; supply station trouble
IF X="AE"!(X="AR")
SET ERR="1F"
GOTO ERR
+9 ;
+10 ; missing segments
XECUTE HLNEXT
IF HLQUIT'>0
SET ERR="1A"
GOTO ERR
+11 SET PRCPHL(LNCNT)=HLNODE
SET J=0
SET LNCNT=LNCNT+1
SET I=1
+12 SET X=$$FLD^HLCSUTL(HLNODE,1)
+13 ;
+14 ; can build user message from ERR segs
FOR
if $DATA(ERR)
GOTO ERR
if X'="ERR"
QUIT
Begin DoDot:1
+15 ; missing segments
XECUTE HLNEXT
IF HLQUIT'>0
SET ERR="1A"
SET X="OUT"
QUIT
+16 SET PRCPHL(LNCNT)=HLNODE
SET J=0
SET LNCNT=LNCNT+1
SET I=1
+17 SET X=$$FLD^HLCSUTL(HLNODE,1)
End DoDot:1
+18 ;
+19 ; wrong segment name
IF X'="QRD"
SET ERR="1A"
GOTO ERR
+20 ;
QRD ; QRD SEGMENT
+1 IF $$FLD^HLCSUTL(HLNODE,3)'="R"!($$FLD^HLCSUTL(HLNODE,4)'="D")!($$FLD^HLCSUTL(HLNODE,5)'="QOH")!($$FLD^HLCSUTL(HLNODE,10)'="STA")
SET ERR="1E"
GOTO ERR
+2 SET J=$$FLD^HLCSUTL(HLNODE,13)
IF J]""
IF J'="S"
SET ERR="1E"
GOTO ERR
+3 ;
+4 ; missing segments
XECUTE HLNEXT
IF HLQUIT'>0
SET ERR="1A"
GOTO ERR
+5 SET PRCPHL(LNCNT)=HLNODE
SET J=0
SET LNCNT=LNCNT+1
SET I=1
+6 ; wrong segment name
IF $$FLD^HLCSUTL(HLNODE,1)'="ORC"
SET ERR="1A"
GOTO ERR
+7 DO ORC
IF $DATA(ERR)
GOTO ERR
+8 ;
+9 ; missing segments
XECUTE HLNEXT
IF HLQUIT'>0
SET ERR="1A"
GOTO ERR
+10 ;
LOOP SET PRCPHL(LNCNT)=HLNODE
SET J=0
SET LNCNT=LNCNT+1
SET I=1
+1 ; wrong segment name
IF $$FLD^HLCSUTL(HLNODE,1)'="NTE"
SET ERR="1A"
GOTO ERR
NTE ; READ NTE SEGMENT
+1 ; ID~NAME~QTY
SET PRCPDATA=$$FLD^HLCSUTL(HLNODE,4)
+2 SET PRCPITEM=$PIECE(PRCPDATA,$EXTRACT(HL("ECH"),1),1,2)
+3 ; item number invalid
IF $PIECE(PRCPITEM,$EXTRACT(HL("ECH"),1),1)'=+PRCPITEM!(+PRCPITEM=0)
DO WARN
XECUTE HLNEXT
if HLQUIT'>0
GOTO Q
KILL WARN
GOTO LOOP
+4 ; item number not in file 441
IF '$DATA(^PRC(441,+PRCPITEM,0))
DO WARN
XECUTE HLNEXT
if HLQUIT'>0
GOTO Q
KILL WARN
GOTO LOOP
+5 ; I '$D(^PRCP(445,PRCPSECN,1,$P(PRCPITEM,$E(HL("ECH"),1),1))) S ERR="6C" G ERR
+6 ; 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
+7 SET PRCPLEFT=$PIECE(PRCPDATA,$EXTRACT(HL("ECH"),1),3)
+8 IF +PRCPLEFT'=PRCPLEFT!(PRCPLEFT>999999)!(PRCPLEFT<-999999)
SET ERR=5
GOTO ERR
+9 DO PROCESS
IF $DATA(ERR)
GOTO ERR
+10 ;
+11 XECUTE HLNEXT
IF HLQUIT'>0
GOTO Q
+12 GOTO LOOP
+13 ;
+14 ; ORC SEGMENT
ORC SET PRCPOC=$$FLD^HLCSUTL(HLNODE,2)
+1 SET PRCPSEC=$$FLD^HLCSUTL(HLNODE,5)
+2 ;
+3 ; order control wrong
IF PRCPOC'="OK"
SET ERR="1C"
QUIT
+4 ;
+5 ; get site and IP information
+6 IF PRCPSEC']""
SET ERR="3A"
QUIT
+7 SET PRCPSEC=$PIECE(PRCPSEC,$EXTRACT(HL("ECH"),1),2)
+8 SET PRCPSITE=$PIECE(PRCPSEC,"-",1)
+9 IF PRCPSITE']""
SET ERR="3E"
QUIT
+10 ; wrong site
IF '$DATA(^PRC(411,PRCPSITE,0))
SET ERR="3D"
QUIT
+11 SET DIC="^PRCP(445,"
SET DIC(0)="X"
SET X=PRCPSEC
SET PRCPPRIV=1
+12 DO ^DIC
KILL DIC
+13 ; secondary not in GIP
IF Y=-1
SET ERR="3A"
QUIT
+14 SET PRCPSECN=$PIECE(Y,"^",1)
+15 IF PRCPSECN']""
SET ERR="3A"
QUIT
+16 ; not a secondary
IF $PIECE(^PRCP(445,PRCPSECN,0),"^",3)'="S"
SET ERR="3B"
QUIT
+17 ;
+18 SET PRCPTIME=$$FLD^HLCSUTL(HLNODE,10)
+19 SET PRCPTIME=$$FMDATE^HLFNC(PRCPTIME)
+20 SET PRCPUSER=$$FLD^HLCSUTL(HLNODE,11)
+21 SET PRCPUSER=$$FMNAME^HLFNC(PRCPUSER)
+22 QUIT
+23 ;
WARN NEW ITEM,PRCPXMY,XMB,XMDUZ,XMY
+1 ; send to secondary inventory point managers
DO GETUSER^PRCPXTRM(PRCPSECN)
if '$ORDER(PRCPXMY(""))
QUIT
+2 SET ITEM=0
+3 FOR
SET ITEM=$ORDER(PRCPXMY(ITEM))
if ITEM'>0
QUIT
IF PRCPXMY(ITEM)=1
SET XMY(ITEM)=""
+4 SET XMB(1)=PRCPSEC
+5 SET XMB(2)=PRCPITEM
+6 SET XMB(3)=HLMTIENS_"."_HLMTIEN
+7 SET XMB="PRCP_BAD_ITEM_QOH"
+8 SET XMDUZ="SUPPLY STATION INTERFACE"
+9 DO EN^XMB
+10 QUIT
+11 ;
PROCESS NEW %,%H,%I,DA,PRCPHL7,PRCPITNM,PRCPTXNT,PRCPMGTP,DIC,DIE,DR,N,T,X,Y
+1 IF 'PRCPTXN
Begin DoDot:1
+2 SET X="PRCPHL7TXN"
+3 IF $DATA(^PRCS(410.1,"B",X))
Begin DoDot:2
+4 SET N=""
SET N=$ORDER(^PRCS(410.1,"B",X,N))
SET DA=N
+5 LOCK +^PRCS(410.1,DA):15
IF $TEST=0
SET ERR=198
+6 SET T=$PIECE(^PRCS(410.1,N,0),"^",2)+1
if T<1
SET T=1
End DoDot:2
IF $DATA(ERR)
QUIT
+7 IF '$DATA(^PRCS(410.1,"B",X))
Begin DoDot:2
+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
End DoDot:2
IF $DATA(ERR)
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)
+15 ;
+16 SET X=T
+17 SET DIC="^PRCP(447.1,"
+18 SET DIC(0)="L"
+19 SET DLAYGO=447.1
+20 DO ^DIC
KILL DIC,DLAYGO
+21 IF Y=-1
SET ERR=100
QUIT
+22 IF $PIECE(Y,"^",3)'=1
SET ERR=101
QUIT
+23 SET (DA,PRCPTXN)=Y+0
+24 LOCK +^PRCP(447.1,DA):3
IF $TEST=0
SET ERR=102
QUIT
+25 SET DIE="^PRCP(447.1,"
+26 SET DA=PRCPTXN
+27 DO NOW^%DTC
+28 SET PRCPTXNT=%
+29 SET PRCPMGTP=HL("MTN")_HL("ETN")
+30 SET PRCPHL7=HLMTIENS_"."_HLMTIEN
+31 SET DR="1///^S X=PRCPSITE;2///^S X=PRCPSECN;3///^S X=PRCPTXNT;4///^S X=PRCPMGTP;5///^S X=PRCPHL7;8///^S X=PRCPTIME"
+32 DO ^DIE
+33 KILL DIE,DR
End DoDot:1
IF $DATA(ERR)
QUIT
+34 SET DIC="^PRCP(447.1,"_PRCPTXN_",1,"
+35 SET DA(1)=PRCPTXN
+36 SET DIC(0)="L"
+37 SET DLAYGO=447.1
+38 SET DIC("P")=$PIECE(^DD(447.1,7,0),"^",2)
+39 SET X=$PIECE(PRCPITEM,$EXTRACT(HL("ECH"),1),1)
+40 ; over rides screen to omit finding case carts/IK's
SET PRCPSET="I 1"
+41 DO ^DIC
KILL DIC,DA,DLAYGO
+42 IF Y=-1
SET ERR=110
QUIT
+43 ; add quantity for an item in different bins
IF $PIECE(Y,"^",3)'=1
SET PRCPLEFT=PRCPLEFT+$PIECE($GET(^PRCP(447.1,PRCPTXN,1,+Y,0)),"^",2)
+44 SET DIE="^PRCP(447.1,"_PRCPTXN_",1,"
+45 SET DA=+Y
+46 SET PRCPITNM=$PIECE(PRCPITEM,$EXTRACT(HL("ECH"),1),2)
+47 SET DR="1///^S X=PRCPLEFT;3///^S X=PRCPITNM"
+48 DO ^DIE
KILL DIC,DIE,DR
+49 QUIT
+50 ;
ERR ;
+1 IF $DATA(ERR)
SET NUMBER=ERR
+2 IF $DATA(WARN)
SET NUMBER=WARN
+3 SET PRCP7("SIPNAME")="AN UNKNOWN INVENTORY POINT"
+4 IF $DATA(PRCPSEC)
IF PRCPSEC]""
SET PRCP7("SIPNAME")=PRCPSEC
+5 IF '$DATA(PRCPSECN)
SET PRCPSECN=0
+6 SET PRCP7("ITEM")=""
+7 IF $DATA(PRCPITEM)
SET PRCP7("ITEM")=$PIECE(PRCPITEM,$EXTRACT(HL("ECH"),1),1)
+8 SET PRCP7("NAME")=""
+9 IF $DATA(PRCPITEM)
SET PRCP7("NAME")=$PIECE(PRCPITEM,$EXTRACT(HL("ECH"),1),2)
+10 SET PRCP7("LEFT")=""
IF $DATA(PRCPLEFT)
SET PRCP7("LEFT")=PRCPLEFT
+11 DO ERR^PRCPHLM0(NUMBER,"PRCP_BAD_QUERY",PRCPSECN,.PRCP7,HLMTIENS_"."_HLMTIEN,.PRCPHL)
+12 IF ERR
IF PRCPTXN
SET DA=PRCPTXN
SET DIK="^PRCP(447.1,"
DO ^DIK
+13 ;
Q IF PRCPTXN
LOCK -^PRCP(447.1,PRCPTXN)
+1 QUIT
