- 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 Jan 18, 2025@03:15:08 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