PRCPHLQU ;WISC/CC/DWA-Build/receive HL7 messages for QOH queries ;4/00
V ;;5.1;IFCAP;**1,24,52**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
Q
;
BLDSEG(INVPT) ;
;
N %,%H,%I,CNT,DATETIME,HLA,HLCS,HLEVN,HLFS,MC,MYRESULT,MYOPTNS,SEG
S CNT=0
I $P($G(^PRCP(445,INVPT,5)),"^",1)']"" Q ; no supply station
;
; set up environment for message
1 D INIT^HLFNC2("PRCP EV QOH REQ",.HL)
; S HLL("LINKS",1)="PRCP EV QOH REQ"_"^"_$P(^PRCP(445.5,$P(^PRCP(445,INVPT,5),"^",1),0),"^",3)
I $G(HL) D Q ; error occurred
. ; put error handler here for init failure
. W !,"HL7 can't build your QOH update request now. Please try later."
. W !,"HL7 Error: "_$P(HL,"^",2)
S HLFS=$G(HL("FS")) I HLFS="" S HLFS="|"
S HLCS=$E(HL("ECH"),1)
;
; Add message txt to HLA array
; create QRD segment
2 D NOW^%DTC S DATETIME=$P(17000000+%,".",1)_$P(%,".",2)
S SEG="QRD"_HL("FS")_DATETIME_HL("FS")_"R"_HL("FS")_"D"_HL("FS")_"QOH"_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_"STA"_HL("FS")_HL("FS")_HL("FS")_"S"
S HLA("HLS",1)=SEG
;
; create QRF segment
S SEG="QRF"_HL("FS")_HL("FS")_DATETIME_HL("FS")_HL("FS")_HL("FS")_"~"_$P(^PRCP(445,INVPT,0),"^",1)
S HLA("HLS",2)=SEG
;
S HLL("LINKS",1)="PRCP SU QOH REQ"_"^"_$P(^PRCP(445.5,$P(^PRCP(445,INVPT,5),"^",1),0),"^",3)
;
;call HL7 to transmit message
3 D GENERATE^HLMA("PRCP EV QOH REQ","LM",1,.MYRESULT,"",.MYOPTNS)
I $P(MYRESULT,"^",2,3)]"" D
. ; error handler for message send failures
. W !,"ERROR: ",MYRESULT
Q
;
GETMSG(PRCPDA,PRCPDONE) ; receive query information from file 447.1
N ITEMDATA,PRCPDATA,PRCPHL7,PRCPITDA,PRCPITEM,PRCPITNM,PRCPLEFT,PRCPQTY,PRCPREP,PRCPSEC,PRCPSITE,PRCPSSFL,PRCPWHEN
;
S PRCPDATA=^PRCP(447.1,PRCPDA,0)
S PRCPHL7=$P(PRCPDATA,"^",6)_".447.1"
S PRCPSITE=$P(PRCPDATA,"^",2)
S PRCPSEC=$P(PRCPDATA,"^",3)
S PRCPWHEN=$P(PRCPDATA,"^",4)
S PRCPREP=0 ; flag to replace current GIP values
S PRCPSSFL=$P($G(^PRCP(445.5,$P($G(^PRCP(445,PRCPSEC,5)),"^",1),0)),"^",2)
;
L +^PRCP(445,PRCPSEC,7):3 I $T=0 Q
D ADD^PRCPULOC(445,PRCPSEC_"-7",0,"HL7 Transaction processing")
S PRCPREP=$G(^PRCP(445,PRCPSEC,7))
I +PRCPREP=0!($P(PRCPREP,"^",2)]""&($P(PRCPREP,"^",2)'<PRCPWHEN)) D
. S PRCPREP=0
. L -^PRCP(445,PRCPSEC,7)
. D CLEAR^PRCPULOC(445,PRCPSEC_"-7",0)
I '$D(^PRCP(445,PRCPSEC)) S ERR="3A" G ERR ; secondary not in GIP
I $P(^PRCP(445,PRCPSEC,0),"^",3)'="S" S ERR="3B" G ERR ; not a secondary
I $P($G(^PRCP(445,PRCPSEC,5)),"^",1)']"" S ERR="3F" G ERR ; not a supply station secondary
S PRCPHLPO("DATE")=PRCPWHEN
S PRCPHLPO("REASON")=""
S PRCPHLPO("RECIPIENT")=""
S PRCPHLPO("USER")=""
I PRCPREP'=0 D
. N Y
. S Y=$P(PRCPREP,"^",2) D DD^%DT
. S PRCPHLPO("REASON")=":Authorized "_Y_" by "_$P(^VA(200,+PRCPREP,0),"^",1)
. S PRCPHLPO("USER")=$P(PRCPREP,"^",1)
. S PRCPHLPO("TRAN")=$$ORDERNO^PRCPUTRX(PRCPSEC)
;
S PRCPITDA=0
LOOP S PRCPITDA=$O(^PRCP(447.1,PRCPDA,1,PRCPITDA)) I '+PRCPITDA G Q
S PRCPDATA=^PRCP(447.1,PRCPDA,1,PRCPITDA,0)
S PRCPITEM=$P(PRCPDATA,"^",1)
S PRCPITNM=$P(PRCPDATA,"^",4)
S PRCPLEFT=$P(PRCPDATA,"^",2)
I '$D(^PRCP(445,PRCPSEC,1,PRCPITEM,0)) S PRCPQTY(+PRCPITEM)=PRCPLEFT_"^"_PRCPITNM_"^**Not in Inv Pt." G LOOP
I $P(^PRCP(445,PRCPSEC,1,PRCPITEM,0),"^",9)'>0 S PRCPQTY(+PRCPITEM)=+PRCPLEFT_"^"_PRCPITNM_"^**Not a SS item" G LOOP
I $P($G(^PRC(441,+PRCPITEM,0)),"^",6)="S" S PRCPQTY(+PRCPITEM)=+PRCPLEFT_"^"_PRCPITNM_"^**CC or IK, not SS item" G LOOP
; compare name in 445 with name sent, CONTINUE
I PRCPSSFL="O",$P(^PRC(441,PRCPITEM,0),"^",2)'=PRCPITNM D NAME^PRCPHL70(PRCPSEC,PRCPITEM,PRCPITNM,PRCPSSFL,PRCPHL7) ; name differs, send message
I PRCPSSFL="S",$G(^PRCP(445,PRCPSEC,1,PRCPITEM,6))'=PRCPITNM D NAME^PRCPHL70(PRCPSEC,PRCPITEM,PRCPITNM,PRCPSSFL,PRCPHL7) ; name differs, send message
S PRCPDATA=$G(^PRCP(445,PRCPSEC,1,PRCPITEM,9))
I $P(PRCPDATA,"^",2)'>PRCPWHEN D
. S $P(PRCPDATA,"^",2)=PRCPWHEN
. S $P(PRCPDATA,"^",1)=PRCPLEFT
. S ^PRCP(445,PRCPSEC,1,PRCPITEM,9)=PRCPDATA
S PRCPHLPO("ITEM")=^PRCP(445,PRCPSEC,1,PRCPITEM,0)
I PRCPREP'=0 D
. S PRCPHLPO("QTY")=PRCPLEFT-$P(PRCPHLPO("ITEM"),"^",7)
. S PRCPHLPO("INVVAL")=$J(PRCPHLPO("QTY")*$P(PRCPHLPO("ITEM"),"^",22),0,2)
. S PRCPHLPO("SELVAL")=PRCPHLPO("INVVAL")
. D UPDATE^PRCPHL1(PRCPSEC,PRCPITEM,PRCPLEFT,.PRCPHLPO,"Q")
I PRCPREP=0,$P(PRCPHLPO("ITEM"),"^",7)'=PRCPLEFT S PRCPQTY(PRCPITEM)=PRCPLEFT_"^"_$P(PRCPHLPO("ITEM"),"^",7)
G LOOP
;
Q N ITEM,ITEMNAME,LN,PRCPXMY,QTYSS,QTYIP,SSTYPE,XMB,XMDUZ,XMTEXT
S SSTYPE=$P(^PRCP(445.5,$P(^PRCP(445,PRCPSEC,5),"^",1),0),"^",2)
K ^TMP($J,"PRCPHL7")
S ITEM=0,LN=1
F S ITEM=$O(PRCPQTY(ITEM)) Q:'ITEM D
. S ITEMNAME=$P($G(^PRCP(445,PRCPSEC,1,ITEM,6)),"^",1)
. I SSTYPE="O" S ITEMNAME=$P(^PRC(441,ITEM,0),"^",2)
. S QTYSS=+PRCPQTY(ITEM),QTYIP=+$P(PRCPQTY(ITEM),"^",2)
. S ^TMP($J,"PRCPHL7",1,LN,0)=$E(" ",$L(QTYIP)+1,7)_QTYIP_" "_$E(" ",$L(QTYSS)+1,7)_QTYSS_" "_$E(" ",$L(ITEM)+1,7)_ITEM_" "_$E(ITEMNAME,1,30)_" "_$P(PRCPQTY(ITEM),"^",3)
. S LN=LN+1
I PRCPREP=0,'$O(PRCPQTY(0)) S ^TMP($J,"PRCPHL7",1,1,0)="<no discrepancies found>"
I PRCPREP'=0 S ^TMP($J,"PRCPHL7",1,1,0)="<The GIP on-hand quantity has been adjusted to supply station totals>"
S ^TMP($J,"PRCPHL7",1)=LN
D GETUSER^PRCPXTRM(PRCPSEC) Q:'$O(PRCPXMY("")) ; send message to secondary inventory point managers
F S ITEM=$O(PRCPXMY(ITEM)) Q:ITEM'>0 I PRCPXMY(ITEM)=1 S XMY(ITEM)=""
S XMTEXT="^TMP($J,""PRCPHL7"",1,"
S XMB(1)=$$INVNAME^PRCPUX1(PRCPSEC)
S XMB="PRCP_ALL_ITEMS_QTY_UPDATE"
S XMDUZ="SUPPLY STATION INTERFACE"
D EN^XMB
K ^TMP($J,"PRCPHL7")
;
S $P(^PRCP(445,PRCPSEC,6),"^",1)=PRCPWHEN
I PRCPREP'=0 D
. N DIE,DA,DR
. L -^PRCP(445,PRCPSEC,7) D CLEAR^PRCPULOC(445,PRCPSEC_"-7",0)
. S DIE="^PRCP(445,",DA=PRCPSEC,DR="24////@;25////@" D ^DIE
S PRCPDONE=1
Q
;
ERR ;
N NUMBER,PRCPXMY
S NUMBER=ERR
S PRCPHLPO("SIPNAME")="" I $D(PRCPSEC) S PRCPHLPO("SIPNAME")=$$INVNAME^PRCPUX1(PRCPSEC)
S PRCPHLPO("ITEM")="" I $D(PRCPITEM) S PRCPHLPO("ITEM")=PRCPITEM
S PRCPHLPO("NAME")="" I $D(PRCPITEM) S PRCPHLPO("NAME")=PRCPITNM
S PRCPHLPO("LEFT")="" I $D(PRCPLEFT) S PRCPHLPO("LEFT")=PRCPLEFT
D ERR^PRCPHLM0(NUMBER,"PRCP_BAD_QUERY",PRCPSEC,.PRCPHLPO,PRCPHL7,"")
S PRCPDONE=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPHLQU 6297 printed Sep 23, 2025@19:50:01 Page 2
PRCPHLQU ;WISC/CC/DWA-Build/receive HL7 messages for QOH queries ;4/00
V ;;5.1;IFCAP;**1,24,52**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
+3 QUIT
+4 ;
BLDSEG(INVPT) ;
+1 ;
+2 NEW %,%H,%I,CNT,DATETIME,HLA,HLCS,HLEVN,HLFS,MC,MYRESULT,MYOPTNS,SEG
+3 SET CNT=0
+4 ; no supply station
IF $PIECE($GET(^PRCP(445,INVPT,5)),"^",1)']""
QUIT
+5 ;
+6 ; set up environment for message
1 DO INIT^HLFNC2("PRCP EV QOH REQ",.HL)
+1 ; S HLL("LINKS",1)="PRCP EV QOH REQ"_"^"_$P(^PRCP(445.5,$P(^PRCP(445,INVPT,5),"^",1),0),"^",3)
+2 ; error occurred
IF $GET(HL)
Begin DoDot:1
+3 ; put error handler here for init failure
+4 WRITE !,"HL7 can't build your QOH update request now. Please try later."
+5 WRITE !,"HL7 Error: "_$PIECE(HL,"^",2)
End DoDot:1
QUIT
+6 SET HLFS=$GET(HL("FS"))
IF HLFS=""
SET HLFS="|"
+7 SET HLCS=$EXTRACT(HL("ECH"),1)
+8 ;
+9 ; Add message txt to HLA array
+10 ; create QRD segment
2 DO NOW^%DTC
SET DATETIME=$PIECE(17000000+%,".",1)_$PIECE(%,".",2)
+1 SET SEG="QRD"_HL("FS")_DATETIME_HL("FS")_"R"_HL("FS")_"D"_HL("FS")_"QOH"_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_"STA"_HL("FS")_HL("FS")_HL("FS")_"S"
+2 SET HLA("HLS",1)=SEG
+3 ;
+4 ; create QRF segment
+5 SET SEG="QRF"_HL("FS")_HL("FS")_DATETIME_HL("FS")_HL("FS")_HL("FS")_"~"_$PIECE(^PRCP(445,INVPT,0),"^",1)
+6 SET HLA("HLS",2)=SEG
+7 ;
+8 SET HLL("LINKS",1)="PRCP SU QOH REQ"_"^"_$PIECE(^PRCP(445.5,$PIECE(^PRCP(445,INVPT,5),"^",1),0),"^",3)
+9 ;
+10 ;call HL7 to transmit message
3 DO GENERATE^HLMA("PRCP EV QOH REQ","LM",1,.MYRESULT,"",.MYOPTNS)
+1 IF $PIECE(MYRESULT,"^",2,3)]""
Begin DoDot:1
+2 ; error handler for message send failures
+3 WRITE !,"ERROR: ",MYRESULT
End DoDot:1
+4 QUIT
+5 ;
GETMSG(PRCPDA,PRCPDONE) ; receive query information from file 447.1
+1 NEW ITEMDATA,PRCPDATA,PRCPHL7,PRCPITDA,PRCPITEM,PRCPITNM,PRCPLEFT,PRCPQTY,PRCPREP,PRCPSEC,PRCPSITE,PRCPSSFL,PRCPWHEN
+2 ;
+3 SET PRCPDATA=^PRCP(447.1,PRCPDA,0)
+4 SET PRCPHL7=$PIECE(PRCPDATA,"^",6)_".447.1"
+5 SET PRCPSITE=$PIECE(PRCPDATA,"^",2)
+6 SET PRCPSEC=$PIECE(PRCPDATA,"^",3)
+7 SET PRCPWHEN=$PIECE(PRCPDATA,"^",4)
+8 ; flag to replace current GIP values
SET PRCPREP=0
+9 SET PRCPSSFL=$PIECE($GET(^PRCP(445.5,$PIECE($GET(^PRCP(445,PRCPSEC,5)),"^",1),0)),"^",2)
+10 ;
+11 LOCK +^PRCP(445,PRCPSEC,7):3
IF $TEST=0
QUIT
+12 DO ADD^PRCPULOC(445,PRCPSEC_"-7",0,"HL7 Transaction processing")
+13 SET PRCPREP=$GET(^PRCP(445,PRCPSEC,7))
+14 IF +PRCPREP=0!($PIECE(PRCPREP,"^",2)]""&($PIECE(PRCPREP,"^",2)'<PRCPWHEN))
Begin DoDot:1
+15 SET PRCPREP=0
+16 LOCK -^PRCP(445,PRCPSEC,7)
+17 DO CLEAR^PRCPULOC(445,PRCPSEC_"-7",0)
End DoDot:1
+18 ; secondary not in GIP
IF '$DATA(^PRCP(445,PRCPSEC))
SET ERR="3A"
GOTO ERR
+19 ; not a secondary
IF $PIECE(^PRCP(445,PRCPSEC,0),"^",3)'="S"
SET ERR="3B"
GOTO ERR
+20 ; not a supply station secondary
IF $PIECE($GET(^PRCP(445,PRCPSEC,5)),"^",1)']""
SET ERR="3F"
GOTO ERR
+21 SET PRCPHLPO("DATE")=PRCPWHEN
+22 SET PRCPHLPO("REASON")=""
+23 SET PRCPHLPO("RECIPIENT")=""
+24 SET PRCPHLPO("USER")=""
+25 IF PRCPREP'=0
Begin DoDot:1
+26 NEW Y
+27 SET Y=$PIECE(PRCPREP,"^",2)
DO DD^%DT
+28 SET PRCPHLPO("REASON")=":Authorized "_Y_" by "_$PIECE(^VA(200,+PRCPREP,0),"^",1)
+29 SET PRCPHLPO("USER")=$PIECE(PRCPREP,"^",1)
+30 SET PRCPHLPO("TRAN")=$$ORDERNO^PRCPUTRX(PRCPSEC)
End DoDot:1
+31 ;
+32 SET PRCPITDA=0
LOOP SET PRCPITDA=$ORDER(^PRCP(447.1,PRCPDA,1,PRCPITDA))
IF '+PRCPITDA
GOTO Q
+1 SET PRCPDATA=^PRCP(447.1,PRCPDA,1,PRCPITDA,0)
+2 SET PRCPITEM=$PIECE(PRCPDATA,"^",1)
+3 SET PRCPITNM=$PIECE(PRCPDATA,"^",4)
+4 SET PRCPLEFT=$PIECE(PRCPDATA,"^",2)
+5 IF '$DATA(^PRCP(445,PRCPSEC,1,PRCPITEM,0))
SET PRCPQTY(+PRCPITEM)=PRCPLEFT_"^"_PRCPITNM_"^**Not in Inv Pt."
GOTO LOOP
+6 IF $PIECE(^PRCP(445,PRCPSEC,1,PRCPITEM,0),"^",9)'>0
SET PRCPQTY(+PRCPITEM)=+PRCPLEFT_"^"_PRCPITNM_"^**Not a SS item"
GOTO LOOP
+7 IF $PIECE($GET(^PRC(441,+PRCPITEM,0)),"^",6)="S"
SET PRCPQTY(+PRCPITEM)=+PRCPLEFT_"^"_PRCPITNM_"^**CC or IK, not SS item"
GOTO LOOP
+8 ; compare name in 445 with name sent, CONTINUE
+9 ; name differs, send message
IF PRCPSSFL="O"
IF $PIECE(^PRC(441,PRCPITEM,0),"^",2)'=PRCPITNM
DO NAME^PRCPHL70(PRCPSEC,PRCPITEM,PRCPITNM,PRCPSSFL,PRCPHL7)
+10 ; name differs, send message
IF PRCPSSFL="S"
IF $GET(^PRCP(445,PRCPSEC,1,PRCPITEM,6))'=PRCPITNM
DO NAME^PRCPHL70(PRCPSEC,PRCPITEM,PRCPITNM,PRCPSSFL,PRCPHL7)
+11 SET PRCPDATA=$GET(^PRCP(445,PRCPSEC,1,PRCPITEM,9))
+12 IF $PIECE(PRCPDATA,"^",2)'>PRCPWHEN
Begin DoDot:1
+13 SET $PIECE(PRCPDATA,"^",2)=PRCPWHEN
+14 SET $PIECE(PRCPDATA,"^",1)=PRCPLEFT
+15 SET ^PRCP(445,PRCPSEC,1,PRCPITEM,9)=PRCPDATA
End DoDot:1
+16 SET PRCPHLPO("ITEM")=^PRCP(445,PRCPSEC,1,PRCPITEM,0)
+17 IF PRCPREP'=0
Begin DoDot:1
+18 SET PRCPHLPO("QTY")=PRCPLEFT-$PIECE(PRCPHLPO("ITEM"),"^",7)
+19 SET PRCPHLPO("INVVAL")=$JUSTIFY(PRCPHLPO("QTY")*$PIECE(PRCPHLPO("ITEM"),"^",22),0,2)
+20 SET PRCPHLPO("SELVAL")=PRCPHLPO("INVVAL")
+21 DO UPDATE^PRCPHL1(PRCPSEC,PRCPITEM,PRCPLEFT,.PRCPHLPO,"Q")
End DoDot:1
+22 IF PRCPREP=0
IF $PIECE(PRCPHLPO("ITEM"),"^",7)'=PRCPLEFT
SET PRCPQTY(PRCPITEM)=PRCPLEFT_"^"_$PIECE(PRCPHLPO("ITEM"),"^",7)
+23 GOTO LOOP
+24 ;
Q NEW ITEM,ITEMNAME,LN,PRCPXMY,QTYSS,QTYIP,SSTYPE,XMB,XMDUZ,XMTEXT
+1 SET SSTYPE=$PIECE(^PRCP(445.5,$PIECE(^PRCP(445,PRCPSEC,5),"^",1),0),"^",2)
+2 KILL ^TMP($JOB,"PRCPHL7")
+3 SET ITEM=0
SET LN=1
+4 FOR
SET ITEM=$ORDER(PRCPQTY(ITEM))
if 'ITEM
QUIT
Begin DoDot:1
+5 SET ITEMNAME=$PIECE($GET(^PRCP(445,PRCPSEC,1,ITEM,6)),"^",1)
+6 IF SSTYPE="O"
SET ITEMNAME=$PIECE(^PRC(441,ITEM,0),"^",2)
+7 SET QTYSS=+PRCPQTY(ITEM)
SET QTYIP=+$PIECE(PRCPQTY(ITEM),"^",2)
+8 SET ^TMP($JOB,"PRCPHL7",1,LN,0)=$EXTRACT(" ",$LENGTH(QTYIP)+1,7)_QTYIP_" "_$EXTRACT(" ",$LENGTH(QTYSS)+1,7)_QTYSS_" "_$EXTRACT(" ",$LENGTH(ITEM)+1,7)_ITEM_" "_$EXTRACT(ITEMNAME,1,30)_" "_$PIECE(PRCPQTY(ITEM),"^",3)
+9 SET LN=LN+1
End DoDot:1
+10 IF PRCPREP=0
IF '$ORDER(PRCPQTY(0))
SET ^TMP($JOB,"PRCPHL7",1,1,0)="<no discrepancies found>"
+11 IF PRCPREP'=0
SET ^TMP($JOB,"PRCPHL7",1,1,0)="<The GIP on-hand quantity has been adjusted to supply station totals>"
+12 SET ^TMP($JOB,"PRCPHL7",1)=LN
+13 ; send message to secondary inventory point managers
DO GETUSER^PRCPXTRM(PRCPSEC)
if '$ORDER(PRCPXMY(""))
QUIT
+14 FOR
SET ITEM=$ORDER(PRCPXMY(ITEM))
if ITEM'>0
QUIT
IF PRCPXMY(ITEM)=1
SET XMY(ITEM)=""
+15 SET XMTEXT="^TMP($J,""PRCPHL7"",1,"
+16 SET XMB(1)=$$INVNAME^PRCPUX1(PRCPSEC)
+17 SET XMB="PRCP_ALL_ITEMS_QTY_UPDATE"
+18 SET XMDUZ="SUPPLY STATION INTERFACE"
+19 DO EN^XMB
+20 KILL ^TMP($JOB,"PRCPHL7")
+21 ;
+22 SET $PIECE(^PRCP(445,PRCPSEC,6),"^",1)=PRCPWHEN
+23 IF PRCPREP'=0
Begin DoDot:1
+24 NEW DIE,DA,DR
+25 LOCK -^PRCP(445,PRCPSEC,7)
DO CLEAR^PRCPULOC(445,PRCPSEC_"-7",0)
+26 SET DIE="^PRCP(445,"
SET DA=PRCPSEC
SET DR="24////@;25////@"
DO ^DIE
End DoDot:1
+27 SET PRCPDONE=1
+28 QUIT
+29 ;
ERR ;
+1 NEW NUMBER,PRCPXMY
+2 SET NUMBER=ERR
+3 SET PRCPHLPO("SIPNAME")=""
IF $DATA(PRCPSEC)
SET PRCPHLPO("SIPNAME")=$$INVNAME^PRCPUX1(PRCPSEC)
+4 SET PRCPHLPO("ITEM")=""
IF $DATA(PRCPITEM)
SET PRCPHLPO("ITEM")=PRCPITEM
+5 SET PRCPHLPO("NAME")=""
IF $DATA(PRCPITEM)
SET PRCPHLPO("NAME")=PRCPITNM
+6 SET PRCPHLPO("LEFT")=""
IF $DATA(PRCPLEFT)
SET PRCPHLPO("LEFT")=PRCPLEFT
+7 DO ERR^PRCPHLM0(NUMBER,"PRCP_BAD_QUERY",PRCPSEC,.PRCPHLPO,PRCPHL7,"")
+8 SET PRCPDONE=1
+9 QUIT
