- 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 Feb 18, 2025@23:40:21 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