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

PRCPHLQU.m

Go to the documentation of this file.
  1. PRCPHLQU ;WISC/CC/DWA-Build/receive HL7 messages for QOH queries ;4/00
  1. V ;;5.1;IFCAP;**1,24,52**;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. Q
  1. ;
  1. BLDSEG(INVPT) ;
  1. ;
  1. N %,%H,%I,CNT,DATETIME,HLA,HLCS,HLEVN,HLFS,MC,MYRESULT,MYOPTNS,SEG
  1. S CNT=0
  1. I $P($G(^PRCP(445,INVPT,5)),"^",1)']"" Q ; no supply station
  1. ;
  1. ; set up environment for message
  1. 1 D 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)
  1. I $G(HL) D Q ; error occurred
  1. . ; put error handler here for init failure
  1. . W !,"HL7 can't build your QOH update request now. Please try later."
  1. . W !,"HL7 Error: "_$P(HL,"^",2)
  1. S HLFS=$G(HL("FS")) I HLFS="" S HLFS="|"
  1. S HLCS=$E(HL("ECH"),1)
  1. ;
  1. ; Add message txt to HLA array
  1. ; create QRD segment
  1. 2 D NOW^%DTC S DATETIME=$P(17000000+%,".",1)_$P(%,".",2)
  1. 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"
  1. S HLA("HLS",1)=SEG
  1. ;
  1. ; create QRF segment
  1. S SEG="QRF"_HL("FS")_HL("FS")_DATETIME_HL("FS")_HL("FS")_HL("FS")_"~"_$P(^PRCP(445,INVPT,0),"^",1)
  1. S HLA("HLS",2)=SEG
  1. ;
  1. S HLL("LINKS",1)="PRCP SU QOH REQ"_"^"_$P(^PRCP(445.5,$P(^PRCP(445,INVPT,5),"^",1),0),"^",3)
  1. ;
  1. ;call HL7 to transmit message
  1. 3 D GENERATE^HLMA("PRCP EV QOH REQ","LM",1,.MYRESULT,"",.MYOPTNS)
  1. I $P(MYRESULT,"^",2,3)]"" D
  1. . ; error handler for message send failures
  1. . W !,"ERROR: ",MYRESULT
  1. Q
  1. ;
  1. GETMSG(PRCPDA,PRCPDONE) ; receive query information from file 447.1
  1. N ITEMDATA,PRCPDATA,PRCPHL7,PRCPITDA,PRCPITEM,PRCPITNM,PRCPLEFT,PRCPQTY,PRCPREP,PRCPSEC,PRCPSITE,PRCPSSFL,PRCPWHEN
  1. ;
  1. S PRCPDATA=^PRCP(447.1,PRCPDA,0)
  1. S PRCPHL7=$P(PRCPDATA,"^",6)_".447.1"
  1. S PRCPSITE=$P(PRCPDATA,"^",2)
  1. S PRCPSEC=$P(PRCPDATA,"^",3)
  1. S PRCPWHEN=$P(PRCPDATA,"^",4)
  1. S PRCPREP=0 ; flag to replace current GIP values
  1. S PRCPSSFL=$P($G(^PRCP(445.5,$P($G(^PRCP(445,PRCPSEC,5)),"^",1),0)),"^",2)
  1. ;
  1. L +^PRCP(445,PRCPSEC,7):3 I $T=0 Q
  1. D ADD^PRCPULOC(445,PRCPSEC_"-7",0,"HL7 Transaction processing")
  1. S PRCPREP=$G(^PRCP(445,PRCPSEC,7))
  1. I +PRCPREP=0!($P(PRCPREP,"^",2)]""&($P(PRCPREP,"^",2)'<PRCPWHEN)) D
  1. . S PRCPREP=0
  1. . L -^PRCP(445,PRCPSEC,7)
  1. . D CLEAR^PRCPULOC(445,PRCPSEC_"-7",0)
  1. I '$D(^PRCP(445,PRCPSEC)) S ERR="3A" G ERR ; secondary not in GIP
  1. I $P(^PRCP(445,PRCPSEC,0),"^",3)'="S" S ERR="3B" G ERR ; not a secondary
  1. I $P($G(^PRCP(445,PRCPSEC,5)),"^",1)']"" S ERR="3F" G ERR ; not a supply station secondary
  1. S PRCPHLPO("DATE")=PRCPWHEN
  1. S PRCPHLPO("REASON")=""
  1. S PRCPHLPO("RECIPIENT")=""
  1. S PRCPHLPO("USER")=""
  1. I PRCPREP'=0 D
  1. . N Y
  1. . S Y=$P(PRCPREP,"^",2) D DD^%DT
  1. . S PRCPHLPO("REASON")=":Authorized "_Y_" by "_$P(^VA(200,+PRCPREP,0),"^",1)
  1. . S PRCPHLPO("USER")=$P(PRCPREP,"^",1)
  1. . S PRCPHLPO("TRAN")=$$ORDERNO^PRCPUTRX(PRCPSEC)
  1. ;
  1. S PRCPITDA=0
  1. LOOP S PRCPITDA=$O(^PRCP(447.1,PRCPDA,1,PRCPITDA)) I '+PRCPITDA G Q
  1. S PRCPDATA=^PRCP(447.1,PRCPDA,1,PRCPITDA,0)
  1. S PRCPITEM=$P(PRCPDATA,"^",1)
  1. S PRCPITNM=$P(PRCPDATA,"^",4)
  1. S PRCPLEFT=$P(PRCPDATA,"^",2)
  1. I '$D(^PRCP(445,PRCPSEC,1,PRCPITEM,0)) S PRCPQTY(+PRCPITEM)=PRCPLEFT_"^"_PRCPITNM_"^**Not in Inv Pt." G LOOP
  1. I $P(^PRCP(445,PRCPSEC,1,PRCPITEM,0),"^",9)'>0 S PRCPQTY(+PRCPITEM)=+PRCPLEFT_"^"_PRCPITNM_"^**Not a SS item" G LOOP
  1. I $P($G(^PRC(441,+PRCPITEM,0)),"^",6)="S" S PRCPQTY(+PRCPITEM)=+PRCPLEFT_"^"_PRCPITNM_"^**CC or IK, not SS item" G LOOP
  1. ; compare name in 445 with name sent, CONTINUE
  1. I PRCPSSFL="O",$P(^PRC(441,PRCPITEM,0),"^",2)'=PRCPITNM D NAME^PRCPHL70(PRCPSEC,PRCPITEM,PRCPITNM,PRCPSSFL,PRCPHL7) ; name differs, send message
  1. I PRCPSSFL="S",$G(^PRCP(445,PRCPSEC,1,PRCPITEM,6))'=PRCPITNM D NAME^PRCPHL70(PRCPSEC,PRCPITEM,PRCPITNM,PRCPSSFL,PRCPHL7) ; name differs, send message
  1. S PRCPDATA=$G(^PRCP(445,PRCPSEC,1,PRCPITEM,9))
  1. I $P(PRCPDATA,"^",2)'>PRCPWHEN D
  1. . S $P(PRCPDATA,"^",2)=PRCPWHEN
  1. . S $P(PRCPDATA,"^",1)=PRCPLEFT
  1. . S ^PRCP(445,PRCPSEC,1,PRCPITEM,9)=PRCPDATA
  1. S PRCPHLPO("ITEM")=^PRCP(445,PRCPSEC,1,PRCPITEM,0)
  1. I PRCPREP'=0 D
  1. . S PRCPHLPO("QTY")=PRCPLEFT-$P(PRCPHLPO("ITEM"),"^",7)
  1. . S PRCPHLPO("INVVAL")=$J(PRCPHLPO("QTY")*$P(PRCPHLPO("ITEM"),"^",22),0,2)
  1. . S PRCPHLPO("SELVAL")=PRCPHLPO("INVVAL")
  1. . D UPDATE^PRCPHL1(PRCPSEC,PRCPITEM,PRCPLEFT,.PRCPHLPO,"Q")
  1. I PRCPREP=0,$P(PRCPHLPO("ITEM"),"^",7)'=PRCPLEFT S PRCPQTY(PRCPITEM)=PRCPLEFT_"^"_$P(PRCPHLPO("ITEM"),"^",7)
  1. G LOOP
  1. ;
  1. Q N ITEM,ITEMNAME,LN,PRCPXMY,QTYSS,QTYIP,SSTYPE,XMB,XMDUZ,XMTEXT
  1. S SSTYPE=$P(^PRCP(445.5,$P(^PRCP(445,PRCPSEC,5),"^",1),0),"^",2)
  1. K ^TMP($J,"PRCPHL7")
  1. S ITEM=0,LN=1
  1. F S ITEM=$O(PRCPQTY(ITEM)) Q:'ITEM D
  1. . S ITEMNAME=$P($G(^PRCP(445,PRCPSEC,1,ITEM,6)),"^",1)
  1. . I SSTYPE="O" S ITEMNAME=$P(^PRC(441,ITEM,0),"^",2)
  1. . S QTYSS=+PRCPQTY(ITEM),QTYIP=+$P(PRCPQTY(ITEM),"^",2)
  1. . 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)
  1. . S LN=LN+1
  1. I PRCPREP=0,'$O(PRCPQTY(0)) S ^TMP($J,"PRCPHL7",1,1,0)="<no discrepancies found>"
  1. I PRCPREP'=0 S ^TMP($J,"PRCPHL7",1,1,0)="<The GIP on-hand quantity has been adjusted to supply station totals>"
  1. S ^TMP($J,"PRCPHL7",1)=LN
  1. D GETUSER^PRCPXTRM(PRCPSEC) Q:'$O(PRCPXMY("")) ; send message to secondary inventory point managers
  1. F S ITEM=$O(PRCPXMY(ITEM)) Q:ITEM'>0 I PRCPXMY(ITEM)=1 S XMY(ITEM)=""
  1. S XMTEXT="^TMP($J,""PRCPHL7"",1,"
  1. S XMB(1)=$$INVNAME^PRCPUX1(PRCPSEC)
  1. S XMB="PRCP_ALL_ITEMS_QTY_UPDATE"
  1. S XMDUZ="SUPPLY STATION INTERFACE"
  1. D EN^XMB
  1. K ^TMP($J,"PRCPHL7")
  1. ;
  1. S $P(^PRCP(445,PRCPSEC,6),"^",1)=PRCPWHEN
  1. I PRCPREP'=0 D
  1. . N DIE,DA,DR
  1. . L -^PRCP(445,PRCPSEC,7) D CLEAR^PRCPULOC(445,PRCPSEC_"-7",0)
  1. . S DIE="^PRCP(445,",DA=PRCPSEC,DR="24////@;25////@" D ^DIE
  1. S PRCPDONE=1
  1. Q
  1. ;
  1. ERR ;
  1. N NUMBER,PRCPXMY
  1. S NUMBER=ERR
  1. S PRCPHLPO("SIPNAME")="" I $D(PRCPSEC) S PRCPHLPO("SIPNAME")=$$INVNAME^PRCPUX1(PRCPSEC)
  1. S PRCPHLPO("ITEM")="" I $D(PRCPITEM) S PRCPHLPO("ITEM")=PRCPITEM
  1. S PRCPHLPO("NAME")="" I $D(PRCPITEM) S PRCPHLPO("NAME")=PRCPITNM
  1. S PRCPHLPO("LEFT")="" I $D(PRCPLEFT) S PRCPHLPO("LEFT")=PRCPLEFT
  1. D ERR^PRCPHLM0(NUMBER,"PRCP_BAD_QUERY",PRCPSEC,.PRCPHLPO,PRCPHL7,"")
  1. S PRCPDONE=1
  1. Q