Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCPHLP

PRCPHLP.m

Go to the documentation of this file. 
  1. PRCPHLP ;WISC/CC - PROCESS HL7 TXN ON REFILLS AND ORDER POSTING; 4/00
  1. V ;;5.1;IFCAP;**1**;Oct 20, 2000
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1.  N DIC,DIE,DR,ERR,I,J,X,XMB
  1.  N NUMBER,ORDERDA,PRIM
  1.  N PRCPAMT,PRCPHL,PRCPHLPO,PRCPITEM,PRCPLEFT,PRCPOC,PRCPORD
  1.  N PRCPSEC,PRCPSECN,PRCPSET,PRCPSITE,PRCPTIME,PRCPUSER
  1.  ;
  1.  S I=1
  1.  I HL("MTN")'="ORM" S ERR="1B" G ERR ; wrong message name
  1.  X HLNEXT I HLQUIT'>0 S ERR="1A" G ERR ; missing segments
  1.  S PRCPHL(1)=HLNODE,I=2
  1.  ;
  1.  X HLNEXT I HLQUIT'>0 S ERR="1A" G ERR ; missing segments
  1.  S PRCPHL(I)=HLNODE,J=0,I=I+1
  1.  I $$FLD^HLCSUTL(HLNODE,1)'="ORC" S ERR="1A" G ERR ; wrong segment name
  1.  D ORC I $D(ERR) G ERR
  1.  ;
  1.  X HLNEXT I HLQUIT'>0,PRCPOC="OF" S ERR="1A" G ERR ; missing segments
  1.  ; Order completion transactions will only have an ORC segment
  1.  I HLQUIT'>0,PRCPOC="FU" G PROCESS
  1.  S PRCPHL(I)=HLNODE,I=I+1,J=0
  1.  I PRCPOC="FU" S ERR="1A" G ERR ; too many segments for order class code
  1.  I $$FLD^HLCSUTL(HLNODE,1)'="RQD" S ERR="1A" G ERR ; wrong segment name
  1.  ;
  1.  ; RQD SEGMENT
  1. RQD S PRCPITEM=$$FLD^HLCSUTL(HLNODE,5) ; ID~NAME
  1.  S PRCPAMT=$$FLD^HLCSUTL(HLNODE,6) ; REFILL QTY - restock issue units
  1.  ;
  1.  ; check item info
  1.  I +PRCPITEM'=$P(PRCPITEM,$E(HL("ECH"),1),1)!(+PRCPITEM=0) S ERR="6E" G ERR ; item number invalid
  1.  I '$D(^PRCP(445.3,ORDERDA,1,$P(PRCPITEM,$E(HL("ECH"),1),1))) S ERR="6A" G ERR ; item not on order
  1.  I '$D(^PRCP(445,$P(^PRCP(445.3,ORDERDA,0),"^",2),1,$P(PRCPITEM,$E(HL("ECH"),1),1))) S ERR="6B" G ERR ; item not in primary 
  1.  I '$D(^PRCP(445,PRCPSECN,1,$P(PRCPITEM,$E(HL("ECH"),1),1))) S ERR="6C" G ERR
  1.  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
  1.  I $P($G(^PRC(441,$P(PRCPITEM,$E(HL("ECH"),1)),0)),"^",6)="S" S ERR="6G" G ERR ; case cart/ik
  1.  ;
  1.  ; verify amount
  1.  I +PRCPAMT'=PRCPAMT!(PRCPAMT>999999)!(PRCPAMT<-999999) S ERR=4 G ERR
  1.  ;
  1.  X HLNEXT I HLQUIT'>0 S ERR="1A" G ERR ; missing segments
  1.  S PRCPHL(I)=HLNODE,J=0,I=I+1
  1.  I $$FLD^HLCSUTL(HLNODE,1)'="NTE" S ERR="1A" G ERR ; wrong segment name
  1.  ;
  1.  ; READ NTE SEGMENT
  1. NTE S PRCPLEFT=$$FLD^HLCSUTL(HLNODE,4)
  1.  I +PRCPLEFT'=PRCPLEFT!(PRCPLEFT>999999)!(PRCPLEFT<-999999) S ERR=5 G ERR
  1.  ;
  1.  X HLNEXT I HLQUIT'>0 G PROCESS
  1.  S PRCPHL(I)=HLNODE,I=I+1,J=0
  1.  S ERR="1A" G ERR ; too many segments
  1.  G Q
  1.  ;
  1.  ; ORC SEGMENT
  1. ORC S PRCPOC=$$FLD^HLCSUTL(HLNODE,2)
  1.  S PRCPSEC=$$FLD^HLCSUTL(HLNODE,5)
  1.  S PRCPORD=$$FLD^HLCSUTL(HLNODE,3)
  1.  ;
  1.  I PRCPOC'="OF",PRCPOC'="FU" S ERR="1C" Q  ; order control wrong
  1.  ;
  1.  ; find site and IP ien
  1.  S PRCPSEC=$P(PRCPSEC,$E(HL("ECH"),1),2)
  1.  I PRCPSEC']"" S ERR="3E" G ERR
  1.  S PRCPSITE=$P(PRCPSEC,"-",1)
  1.  I PRCPSITE']"" S ERR="3E" Q  ; site missing
  1.  I '$D(^PRC(411,PRCPSITE,0)) S ERR="3D" Q  ; wrong site
  1.  S DIC="^PRCP(445,",DIC(0)="X",X=PRCPSEC,PRCPPRIV=1
  1.  D ^DIC K DIC
  1.  I Y=-1 S ERR="3A" Q  ; secondary not in GIP
  1.  S PRCPSECN=$P(Y,"^",1)
  1.  I $P(^PRCP(445,PRCPSECN,0),"^",3)'="S" S ERR="3B" Q  ; not a secondary
  1.  ;
  1.  S PRIM=$O(^PRCP(445,"AB",PRCPSECN,""))
  1.  I PRIM']"" S ERR="2A" Q
  1.  ; get internal order number
  1.  I PRCPORD]"" D  I $D(ERR) Q
  1.  . S DIC="^PRCP(445.3,",DIC(0)="X",X=PRCPORD,PRCPPRIV=1
  1.  . S DIC("S")="I $P(^(0),U,2)="_PRIM
  1.  . D ^DIC K DIC
  1.  . I Y=-1 S ERR="2A" Q  ; order not in GIP
  1.  . S ORDERDA=$P(Y,"^",1)
  1.  . I $P(^PRCP(445.3,ORDERDA,0),"^",6)="P" S ERR="2B" Q  ; order is posted
  1.  . I $P(^PRCP(445.3,ORDERDA,0),"^",10)']"" S ERR="2C" Q  ; order not to be completed by supply station
  1.  . I $P(^PRCP(445.3,ORDERDA,0),"^",3)'=PRCPSECN S ERR="3C" Q  ; sec on order differs
  1.  I HL("MTN")="ORM",PRCPORD']"" S ERR="2D" Q  ; order number missing
  1.  ;
  1.  S PRCPTIME=$$FLD^HLCSUTL(HLNODE,10)
  1.  S PRCPTIME=$$FMDATE^HLFNC(PRCPTIME)
  1.  S PRCPUSER=$$FLD^HLCSUTL(HLNODE,11)
  1.  S PRCPUSER=$P(PRCPUSER,$E(HL("ECH"),1),2)
  1.  S PRCPUSER=$$FMNAME^HLFNC(PRCPUSER,$E(HL("ECH"),1))
  1.  Q
  1.  ;
  1.  ;
  1. ERR S NUMBER=ERR
  1.  I '$D(PRCPSECN) S PRCPSECN=0
  1.  S PRCPHLPO("ORDER")="" I $D(PRCPORD) S PRCPHLPO("ORDER")=PRCPORD
  1.  S PRCPHLPO("SIPNAME")="AN UNKNOWN INVENTORY POINT"
  1.  I $D(PRCPSEC),PRCPSEC]"" S PRCPHLPO("SIPNAME")=PRCPSEC
  1.  S PRCPHLPO("ITEM")=""
  1.  I $D(PRCPITEM) S PRCPHLPO("ITEM")=$P(PRCPITEM,$E(HL("ECH"),1),1)
  1.  S PRCPHLPO("NAME")=""
  1.  I $D(PRCPITEM) S PRCPHLPO("NAME")=$P(PRCPITEM,$E(HL("ECH"),1),2)
  1.  S PRCPHLPO("QTY")="" I $D(PRCPAMT) S PRCPHLPO("QTY")=PRCPAMT
  1.  S PRCPHLPO("LEFT")="" I $D(PRCPLEFT) S PRCPHLPO("LEFT")=PRCPLEFT
  1.  S PRCPHLPO("TYPE")=PRCPOC
  1.  D ERR^PRCPHLM0(ERR,"PRCP_BAD_ORDER",PRCPSECN,.PRCPHLPO,HLMTIENS_"."_HLMTIEN,.PRCPHL)
  1.  G UNLOCK
  1.  ;
  1.  ;
  1. PROCESS N %,%H,%I,N,PRCPTXN,PRCPTXNT,PRCPMGTP,PRCPHL7,PRCPITNM,CNT,DA,DIC,DIE,DLAYGO,DR,T,X,Y
  1.  S X="PRCPHL7TXN",CNT=0
  1. 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
  1.  . S N="",N=$O(^PRCS(410.1,"B",X,N)),DA=N
  1.  . L +^PRCS(410.1,DA):15 I $T=0 S ERR=198 Q
  1.  . S T=$P(^PRCS(410.1,N,0),"^",2)+1 S:T<1 T=1
  1.  . S $P(^PRCS(410.1,DA,0),"^",2)=+T
  1.  . S $P(^PRCS(410.1,DA,0),"^",3)=DT
  1.  . L -^PRCS(410.1,DA)
  1.  I '$D(^PRCS(410.1,"B",X)) D  I $D(ERR) S CNT=CNT+1 G PROCES0:CNT<10 S CNT=0 G ERR
  1.  . S T=1,DLAYGO=410.1,DIC="^PRCS(410.1,",DIC(0)="FLXZ"
  1.  . D ^DIC K DLAYGO I Y<0 S ERR=199
  1.  . S DA=+Y
  1.  . L +^PRCS(410.1,DA):15 I $T=0 S ERR=198 Q
  1.  . S $P(^PRCS(410.1,DA,0),"^",2)=+T
  1.  . S $P(^PRCS(410.1,DA,0),"^",3)=DT
  1.  . L -^PRCS(410.1,DA)
  1.  ;
  1. PROCES1 S CNT=0,X=T
  1.  S DIC="^PRCP(447.1,"
  1.  S DIC(0)="L"
  1.  S DLAYGO=447.1
  1.  D ^DIC K DIC
  1.  I Y=-1 S ERR=100,CNT=CNT+1 G PROCES1:CNT<10,ERR
  1.  I $P(Y,"^",3)'=1 S ERR=101 G ERR
  1.  S (DA,PRCPTXN)=Y+0
  1.  L +^PRCP(447.1,DA):3 I $T=0 S ERR=102 D UNLOCK G ERR
  1.  S DIE="^PRCP(447.1,"
  1.  S DA=PRCPTXN
  1.  D NOW^%DTC
  1.  S PRCPTXNT=%
  1.  S PRCPHL7=HLMTIENS_"."_HLMTIEN
  1.  S PRCPMGTP=HL("MTN")_HL("ETN")
  1.  S DR="1///^S X=PRCPSITE;2///^S X=PRCPSECN;3///^S X=PRCPTXNT;4///^S X=PRCPMGTP;5///^S X=PRCPHL7;6////^S X=ORDERDA;8///^S X=PRCPTIME;10///^S X=PRCPUSER"
  1.  I PRCPOC="FU" S DR=DR_";11///^S X=PRCPOC"
  1.  D ^DIE
  1.  K DIE,DR
  1.  I PRCPOC="FU" G UNLOCK
  1.  S DIC="^PRCP(447.1,"_PRCPTXN_",1,"
  1.  S DA(1)=PRCPTXN
  1.  S DIC(0)="L"
  1.  S DLAYGO=447.1
  1.  S DIC("P")=$P(^DD(447.1,7,0),"^",2)
  1.  S X=$P(PRCPITEM,$E(HL("ECH"),1),1)
  1.  S PRCPSET="I 1" ; over rides screen to omit finding case carts/IK's
  1.  D ^DIC K DIC,DA,DLAYGO
  1.  I Y=-1 S ERR=110 D UNLOCK G ERR
  1.  I $P(Y,"^",3)'=1 S ERR=111 D UNLOCK G ERR
  1.  S DIE="^PRCP(447.1,"_PRCPTXN_",1,"
  1.  S DA=+Y
  1.  S PRCPITNM=$P(PRCPITEM,$E(HL("ECH"),1),2)
  1.  S DR="1///^S X=PRCPLEFT;2///^S X=PRCPAMT;3///^S X=PRCPITNM"
  1.  D ^DIE K DIE,DIC,DR
  1. UNLOCK I $D(ERR),$D(PRCPTXN),PRCPTXN>0 S DA=PRCPTXN,DIK="^PRCP(447.1," D ^DIK
  1.  I $G(PRCPTXN) L -^PRCP(447.1,PRCPTXN)
  1. Q Q