- 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 Feb 18, 2025@23:40:19 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
