PRCPHLSO ;WISC/CC/DWA-build HL7 messages for distribution order ;4/00
V ;;5.1;IFCAP;**1,52**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
BLDSEG(ORDRDA) ;
N %,%H,%I,CNT,DATETIME,HLA,HLCS,HLEVN,HLFS,INVPT,ITEM,ITEMDA,ITEMNM
N MC,MYOPTION,MYRESULT,ORDRDATA,PRIM,PRIMVN,SEG,X
S CNT=0
;
;set up environment for message
1 D INIT^HLFNC2("PRCP EV REL ORDER",.HL)
I $G(HL) D Q ; error occurred
. W !,"The system can't build an HL7 message now to send your order to"
. W !,"the supply station. Please use the 'SO - Send Order' option later."
. W !,"Error: "_$P(HL,"^",2)
S HLFS=$G(HL("FS")) I HLFS="" S HLFS="|"
S HLCS=$E(HL("ECH"),1)
;
D NOW^%DTC S DATETIME=(17000000+$P(%,".",1))_$P(%,".",2)
; Add message txt to HLA array
; loop through each item in the order
K ^TMP("HLS",$J)
S ORDRDATA=^PRCP(445.3,ORDRDA,0)
S INVPT=$P(ORDRDATA,"^",3) ; secondary inventory point
S PRIM=$P(ORDRDATA,"^",2) ; primary IP
S PRIMVN=PRIM_";PRCP(445,"
S ITEM=0,CNT=0,USERNAME=""
F S ITEM=$O(^PRCP(445.3,ORDRDA,1,ITEM)) Q:'+ITEM D
. S CNT=CNT+1
. ;
. ; create ORC segment
. S SEG="ORC"_HL("FS")_"RF" ; RF = order class
. S SEG=SEG_HL("FS")_$P(ORDRDATA,"^",1) ; order number
. S SEG=SEG_HL("FS")_HL("FS")
. S SEG=SEG_"~"_$P(^PRCP(445,INVPT,0),"^",1) ; secondary inventory point
. S SEG=SEG_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")
. S SEG=SEG_DATETIME_HL("FS")
. ; don't send name if vendor doesn't need it
. S ^TMP("HLS",$J,CNT)=SEG_USERNAME
. ;
. ; create RQD Segment
. S ITEMNM=$P($G(^PRCP(445,INVPT,1,ITEM,6)),"^",1)
. I ITEMNM']"" D ; if no item name, pull from primary or item master
. . S X=$P(^PRCP(445.5,$P(^PRCP(445,INVPT,5),"^",1),0),"^",2)
. . I X="S" S ITEMNM=$P($G(^PRCP(445,PRIM,1,ITEM,6)),"^",1)
. . I X="O" S ITEMNM=$P($G(^PRC(441,ITEM,0)),"^",2)
. S CNT=CNT+1
. S SEG="RQD"_HL("FS")_HL("FS")_HL("FS")_HL("FS")
. S SEG=SEG_ITEM_"~"_ITEMNM
. S SEG=SEG_HL("FS")_$P(^PRCP(445.3,ORDRDA,1,ITEM,0),"^",2) ;qty
. S SEG=SEG_HL("FS")
. S ITEMDA=$P($G(^PRCP(445,PRIM,1,ITEM,0)),"^",5) ; primary unit of issue
. I ITEMDA]"" S SEG=SEG_$P($G(^PRCD(420.5,ITEMDA,0)),"^",1) ; unit of issue
. I ITEMDA']"" S SEG=SEG_"EA" ; GIP unit of issue default
. S ^TMP("HLS",$J,CNT)=SEG
. ;
. ;NTE (to send conversion factor)
. S CNT=CNT+1
. S SEG="NTE"_HL("FS")_1_HL("FS")_"RQD"_HL("FS")
. I PRIMVN]"" S X=$$GETVEN^PRCPUVEN(INVPT,ITEM,PRIMVN,1)
. S SEG=SEG_$P(X,"^",4) ; pkg multiple (conversion factor)
. S ITEMDA=$P($G(^PRCP(445,INVPT,1,ITEM,0)),"^",5) ; secondary unit of issue
. I ITEMDA]"" S SEG=SEG_"~"_$P($G(^PRCD(420.5,ITEMDA,0)),"^",1) ; SECONDARY ISSUE UNIT
. I ITEMDA']"" S SEG=SEG_"EA" ; GIP unit of issue default
. S ^TMP("HLS",$J,CNT)=SEG
;
;notify user that message will be sent
W !,"ORDER INFORMATION WILL BE TRANSMITTED TO THE SUPPLY STATION."
;
;call HL7 to transmit message
3 S HLL("LINKS",1)="PRCP SU REL ORDER"_"^"_$P(^PRCP(445.5,$P(^PRCP(445,INVPT,5),"^",1),0),"^",3)
D GENERATE^HLMA("PRCP EV REL ORDER","GM",1,.MYRESULT,"",.MYOPTION)
I $P(MYRESULT,"^",2,3)]"" D
. ; error handler for message send failures
. W !,"ERROR: ",MYRESULT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPHLSO 3212 printed Apr 09, 2024@21:03:05 Page 2
PRCPHLSO ;WISC/CC/DWA-build HL7 messages for distribution order ;4/00
V ;;5.1;IFCAP;**1,52**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
BLDSEG(ORDRDA) ;
+1 NEW %,%H,%I,CNT,DATETIME,HLA,HLCS,HLEVN,HLFS,INVPT,ITEM,ITEMDA,ITEMNM
+2 NEW MC,MYOPTION,MYRESULT,ORDRDATA,PRIM,PRIMVN,SEG,X
+3 SET CNT=0
+4 ;
+5 ;set up environment for message
1 DO INIT^HLFNC2("PRCP EV REL ORDER",.HL)
+1 ; error occurred
IF $GET(HL)
Begin DoDot:1
+2 WRITE !,"The system can't build an HL7 message now to send your order to"
+3 WRITE !,"the supply station. Please use the 'SO - Send Order' option later."
+4 WRITE !,"Error: "_$PIECE(HL,"^",2)
End DoDot:1
QUIT
+5 SET HLFS=$GET(HL("FS"))
IF HLFS=""
SET HLFS="|"
+6 SET HLCS=$EXTRACT(HL("ECH"),1)
+7 ;
+8 DO NOW^%DTC
SET DATETIME=(17000000+$PIECE(%,".",1))_$PIECE(%,".",2)
+9 ; Add message txt to HLA array
+10 ; loop through each item in the order
+11 KILL ^TMP("HLS",$JOB)
+12 SET ORDRDATA=^PRCP(445.3,ORDRDA,0)
+13 ; secondary inventory point
SET INVPT=$PIECE(ORDRDATA,"^",3)
+14 ; primary IP
SET PRIM=$PIECE(ORDRDATA,"^",2)
+15 SET PRIMVN=PRIM_";PRCP(445,"
+16 SET ITEM=0
SET CNT=0
SET USERNAME=""
+17 FOR
SET ITEM=$ORDER(^PRCP(445.3,ORDRDA,1,ITEM))
if '+ITEM
QUIT
Begin DoDot:1
+18 SET CNT=CNT+1
+19 ;
+20 ; create ORC segment
+21 ; RF = order class
SET SEG="ORC"_HL("FS")_"RF"
+22 ; order number
SET SEG=SEG_HL("FS")_$PIECE(ORDRDATA,"^",1)
+23 SET SEG=SEG_HL("FS")_HL("FS")
+24 ; secondary inventory point
SET SEG=SEG_"~"_$PIECE(^PRCP(445,INVPT,0),"^",1)
+25 SET SEG=SEG_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")
+26 SET SEG=SEG_DATETIME_HL("FS")
+27 ; don't send name if vendor doesn't need it
+28 SET ^TMP("HLS",$JOB,CNT)=SEG_USERNAME
+29 ;
+30 ; create RQD Segment
+31 SET ITEMNM=$PIECE($GET(^PRCP(445,INVPT,1,ITEM,6)),"^",1)
+32 ; if no item name, pull from primary or item master
IF ITEMNM']""
Begin DoDot:2
+33 SET X=$PIECE(^PRCP(445.5,$PIECE(^PRCP(445,INVPT,5),"^",1),0),"^",2)
+34 IF X="S"
SET ITEMNM=$PIECE($GET(^PRCP(445,PRIM,1,ITEM,6)),"^",1)
+35 IF X="O"
SET ITEMNM=$PIECE($GET(^PRC(441,ITEM,0)),"^",2)
End DoDot:2
+36 SET CNT=CNT+1
+37 SET SEG="RQD"_HL("FS")_HL("FS")_HL("FS")_HL("FS")
+38 SET SEG=SEG_ITEM_"~"_ITEMNM
+39 ;qty
SET SEG=SEG_HL("FS")_$PIECE(^PRCP(445.3,ORDRDA,1,ITEM,0),"^",2)
+40 SET SEG=SEG_HL("FS")
+41 ; primary unit of issue
SET ITEMDA=$PIECE($GET(^PRCP(445,PRIM,1,ITEM,0)),"^",5)
+42 ; unit of issue
IF ITEMDA]""
SET SEG=SEG_$PIECE($GET(^PRCD(420.5,ITEMDA,0)),"^",1)
+43 ; GIP unit of issue default
IF ITEMDA']""
SET SEG=SEG_"EA"
+44 SET ^TMP("HLS",$JOB,CNT)=SEG
+45 ;
+46 ;NTE (to send conversion factor)
+47 SET CNT=CNT+1
+48 SET SEG="NTE"_HL("FS")_1_HL("FS")_"RQD"_HL("FS")
+49 IF PRIMVN]""
SET X=$$GETVEN^PRCPUVEN(INVPT,ITEM,PRIMVN,1)
+50 ; pkg multiple (conversion factor)
SET SEG=SEG_$PIECE(X,"^",4)
+51 ; secondary unit of issue
SET ITEMDA=$PIECE($GET(^PRCP(445,INVPT,1,ITEM,0)),"^",5)
+52 ; SECONDARY ISSUE UNIT
IF ITEMDA]""
SET SEG=SEG_"~"_$PIECE($GET(^PRCD(420.5,ITEMDA,0)),"^",1)
+53 ; GIP unit of issue default
IF ITEMDA']""
SET SEG=SEG_"EA"
+54 SET ^TMP("HLS",$JOB,CNT)=SEG
End DoDot:1
+55 ;
+56 ;notify user that message will be sent
+57 WRITE !,"ORDER INFORMATION WILL BE TRANSMITTED TO THE SUPPLY STATION."
+58 ;
+59 ;call HL7 to transmit message
3 SET HLL("LINKS",1)="PRCP SU REL ORDER"_"^"_$PIECE(^PRCP(445.5,$PIECE(^PRCP(445,INVPT,5),"^",1),0),"^",3)
+1 DO GENERATE^HLMA("PRCP EV REL ORDER","GM",1,.MYRESULT,"",.MYOPTION)
+2 IF $PIECE(MYRESULT,"^",2,3)]""
Begin DoDot:1
+3 ; error handler for message send failures
+4 WRITE !,"ERROR: ",MYRESULT
End DoDot:1
+5 QUIT
