159 lines
5.8 KiB
Mathematica
159 lines
5.8 KiB
Mathematica
PRCPHLU ;WISC/CC - PROCESS HL7 TXN ON ITEM UTILIZATION AT THE 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,DLAYGO,DR,ERR,I,J,NUMBER,X,Y
|
|
N PRCPAMT,PRCPHL,PRCPHL7,PRCPITEM,PRCPITNM,PRCPLEFT,PRCPOC,PRCPRCOD,PRCPREAS
|
|
N PRCPREC,PRCPSEC,PRCPSECN,PRCPSITE,PRCPTIME,PRCPTXN,PRCPUSER,PRCP7
|
|
S I=1
|
|
;
|
|
RAS I HL("MTN")'="RAS" 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=I+1,J=0
|
|
;
|
|
X HLNEXT I HLQUIT'>0 S ERR="1A" G ERR ; missing segments
|
|
S PRCPHL(I)=HLNODE,J=0,I=I+1
|
|
S PRCPREC=""
|
|
I $$FLD^HLCSUTL(HLNODE,1)="PID" D I HLQUIT'>0 S ERR="1A" G ERR ; missing segments
|
|
. S PRCPREC=$$FLD^HLCSUTL(HLNODE,6)
|
|
. S PRCPREC=$$FMNAME^HLFNC(PRCPREC,$E(HL("ECH"),1))
|
|
. X HLNEXT
|
|
. 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 S ERR="1A" G ERR ; missing segments
|
|
S PRCPHL(I)=HLNODE,J=0,I=I+1
|
|
I $$FLD^HLCSUTL(HLNODE,1)'="RXA" S ERR="1A" G ERR ; wrong segment name
|
|
;
|
|
; RXA SEGMENT
|
|
RXA S PRCPITEM=$$FLD^HLCSUTL(HLNODE,6) ; ID~NAME
|
|
S PRCPTIME=$$FLD^HLCSUTL(HLNODE,4)
|
|
S PRCPTIME=$$FMDATE^HLFNC(PRCPTIME)
|
|
S PRCPAMT=$$FLD^HLCSUTL(HLNODE,7) ; QTY - 2ndary issue units
|
|
S PRCPUSER=$$FLD^HLCSUTL(HLNODE,11)
|
|
S PRCPUSER=$P(PRCPUSER,$E(HL("ECH"),1),2)
|
|
S PRCPUSER=$$FMNAME^HLFNC(PRCPUSER,$E(HL("ECH"),1))
|
|
S PRCPREAS=$$FLD^HLCSUTL(HLNODE,19)
|
|
S PRCPRCOD=$P(PRCPREAS,$E(HL("ECH"),1),1)
|
|
S PRCPREAS=PRCPRCOD_"~"_$P(PRCPREAS,$E(HL("ECH"),1),2)
|
|
S PRCPLEFT=$$FLD^HLCSUTL(HLNODE,20)
|
|
;
|
|
; verify info extracted
|
|
I +PRCPITEM'=$P(PRCPITEM,$E(HL("ECH"),1),1)!(+PRCPITEM=0) S ERR="6E" G ERR ; item number invalid
|
|
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 +PRCPAMT'=PRCPAMT!(PRCPAMT>999999)!(PRCPAMT<-999999) S ERR=4 G ERR
|
|
I +PRCPLEFT'=PRCPLEFT!(PRCPLEFT>999999)!(PRCPLEFT<-999999) S ERR=5 G ERR
|
|
;
|
|
I PRCPOC="LI",PRCPRCOD'="RTRN",PRCPRCOD'="USGE" S ERR="1D" G ERR
|
|
I PRCPOC="RP",PRCPRCOD]"",PRCPRCOD'="DISP",$E(PRCPRCOD,1,3)'="ADJ" S ERR="1D" 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)'="RXR" S ERR="1A" G ERR ; wrong segment name
|
|
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)
|
|
;
|
|
I HL("MTN")="RAS",PRCPOC'="LI",PRCPOC'="RP" S ERR="1C" Q ; order control wrong
|
|
; get site and IP info
|
|
I PRCPSEC']"" S ERR="3E" Q
|
|
S PRCPSEC=$P(PRCPSEC,$E(HL("ECH"),1),2) I PRCPSEC']"" S ERR="3E" Q
|
|
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 $P(^PRCP(445,PRCPSECN,0),"^",3)'="S" S ERR="3B" G ERR ; not a secondary
|
|
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 PRCP7("SIPNAME")="AN UNKNOWN INVENTORY POINT"
|
|
I $D(PRCPSEC),PRCPSEC]"" S PRCP7("SIPNAME")=PRCPSEC
|
|
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("ACTIVITY")=""
|
|
I $D(PRCPREAS) S PRCP7("ACTIVITY")=$E(PRCPREAS,1,4)
|
|
S PRCP7("QTY")="" I $D(PRCPAMT) S PRCP7("QTY")=PRCPAMT
|
|
S PRCP7("LEFT")="" I $D(PRCPLEFT) S PRCP7("LEFT")=PRCPLEFT
|
|
S PRCP7("RECIPIENT")=""
|
|
I $D(PRCPREC) S PRCP7("RECIPIENT")=PRCPREC
|
|
S PRCP7("USER")=""
|
|
I $D(PRCPUSER) S PRCP7("USER")=PRCPUSER
|
|
D ERR^PRCPHLM0(ERR,"PRCP_BAD_ACTIVITY",PRCPSECN,.PRCP7,HLMTIENS_"."_HLMTIEN,.PRCPHL)
|
|
I ERR,$D(PRCPTXN) S DA=PRCPTXN,DIK="^PRCP(447.1," D ^DIK
|
|
G UNLOCK
|
|
;
|
|
PROCESS N %,%H,%I,PRCPTXNT,PRCPMGTP,CNT,DA,DIC,DIE,DR,N,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)
|
|
;
|
|
S 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 G 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 G ERR
|
|
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;9///^S X=PRCPREC;10///^S X=PRCPUSER;11///^S X=PRCPREAS"
|
|
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 G ERR
|
|
I $P(Y,"^",3)'=1 S ERR=111 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(PRCPTXN),PRCPTXN>0 L -^PRCP(447.1,PRCPTXN)
|
|
Q Q
|