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

PRCPHLSO.m

Go to the documentation of this file.
  1. PRCPHLSO ;WISC/CC/DWA-build HL7 messages for distribution order ;4/00
  1. V ;;5.1;IFCAP;**1,52**;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. Q
  1. BLDSEG(ORDRDA) ;
  1. N %,%H,%I,CNT,DATETIME,HLA,HLCS,HLEVN,HLFS,INVPT,ITEM,ITEMDA,ITEMNM
  1. N MC,MYOPTION,MYRESULT,ORDRDATA,PRIM,PRIMVN,SEG,X
  1. S CNT=0
  1. ;
  1. ;set up environment for message
  1. 1 D INIT^HLFNC2("PRCP EV REL ORDER",.HL)
  1. I $G(HL) D Q ; error occurred
  1. . W !,"The system can't build an HL7 message now to send your order to"
  1. . W !,"the supply station. Please use the 'SO - Send Order' option later."
  1. . W !,"Error: "_$P(HL,"^",2)
  1. S HLFS=$G(HL("FS")) I HLFS="" S HLFS="|"
  1. S HLCS=$E(HL("ECH"),1)
  1. ;
  1. D NOW^%DTC S DATETIME=(17000000+$P(%,".",1))_$P(%,".",2)
  1. ; Add message txt to HLA array
  1. ; loop through each item in the order
  1. K ^TMP("HLS",$J)
  1. S ORDRDATA=^PRCP(445.3,ORDRDA,0)
  1. S INVPT=$P(ORDRDATA,"^",3) ; secondary inventory point
  1. S PRIM=$P(ORDRDATA,"^",2) ; primary IP
  1. S PRIMVN=PRIM_";PRCP(445,"
  1. S ITEM=0,CNT=0,USERNAME=""
  1. F S ITEM=$O(^PRCP(445.3,ORDRDA,1,ITEM)) Q:'+ITEM D
  1. . S CNT=CNT+1
  1. . ;
  1. . ; create ORC segment
  1. . S SEG="ORC"_HL("FS")_"RF" ; RF = order class
  1. . S SEG=SEG_HL("FS")_$P(ORDRDATA,"^",1) ; order number
  1. . S SEG=SEG_HL("FS")_HL("FS")
  1. . S SEG=SEG_"~"_$P(^PRCP(445,INVPT,0),"^",1) ; secondary inventory point
  1. . S SEG=SEG_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")
  1. . S SEG=SEG_DATETIME_HL("FS")
  1. . ; don't send name if vendor doesn't need it
  1. . S ^TMP("HLS",$J,CNT)=SEG_USERNAME
  1. . ;
  1. . ; create RQD Segment
  1. . S ITEMNM=$P($G(^PRCP(445,INVPT,1,ITEM,6)),"^",1)
  1. . I ITEMNM']"" D ; if no item name, pull from primary or item master
  1. . . S X=$P(^PRCP(445.5,$P(^PRCP(445,INVPT,5),"^",1),0),"^",2)
  1. . . I X="S" S ITEMNM=$P($G(^PRCP(445,PRIM,1,ITEM,6)),"^",1)
  1. . . I X="O" S ITEMNM=$P($G(^PRC(441,ITEM,0)),"^",2)
  1. . S CNT=CNT+1
  1. . S SEG="RQD"_HL("FS")_HL("FS")_HL("FS")_HL("FS")
  1. . S SEG=SEG_ITEM_"~"_ITEMNM
  1. . S SEG=SEG_HL("FS")_$P(^PRCP(445.3,ORDRDA,1,ITEM,0),"^",2) ;qty
  1. . S SEG=SEG_HL("FS")
  1. . S ITEMDA=$P($G(^PRCP(445,PRIM,1,ITEM,0)),"^",5) ; primary unit of issue
  1. . I ITEMDA]"" S SEG=SEG_$P($G(^PRCD(420.5,ITEMDA,0)),"^",1) ; unit of issue
  1. . I ITEMDA']"" S SEG=SEG_"EA" ; GIP unit of issue default
  1. . S ^TMP("HLS",$J,CNT)=SEG
  1. . ;
  1. . ;NTE (to send conversion factor)
  1. . S CNT=CNT+1
  1. . S SEG="NTE"_HL("FS")_1_HL("FS")_"RQD"_HL("FS")
  1. . I PRIMVN]"" S X=$$GETVEN^PRCPUVEN(INVPT,ITEM,PRIMVN,1)
  1. . S SEG=SEG_$P(X,"^",4) ; pkg multiple (conversion factor)
  1. . S ITEMDA=$P($G(^PRCP(445,INVPT,1,ITEM,0)),"^",5) ; secondary unit of issue
  1. . I ITEMDA]"" S SEG=SEG_"~"_$P($G(^PRCD(420.5,ITEMDA,0)),"^",1) ; SECONDARY ISSUE UNIT
  1. . I ITEMDA']"" S SEG=SEG_"EA" ; GIP unit of issue default
  1. . S ^TMP("HLS",$J,CNT)=SEG
  1. ;
  1. ;notify user that message will be sent
  1. W !,"ORDER INFORMATION WILL BE TRANSMITTED TO THE SUPPLY STATION."
  1. ;
  1. ;call HL7 to transmit message
  1. 3 S HLL("LINKS",1)="PRCP SU REL ORDER"_"^"_$P(^PRCP(445.5,$P(^PRCP(445,INVPT,5),"^",1),0),"^",3)
  1. D GENERATE^HLMA("PRCP EV REL ORDER","GM",1,.MYRESULT,"",.MYOPTION)
  1. I $P(MYRESULT,"^",2,3)]"" D
  1. . ; error handler for message send failures
  1. . W !,"ERROR: ",MYRESULT
  1. Q