source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPHLSO.m@ 1608

Last change on this file since 1608 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 3.1 KB
Line 
1PRCPHLSO ;WISC/CC/DWA-build HL7 messages for distribution order ;4/00
2V ;;5.1;IFCAP;**1,52**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5BLDSEG(ORDRDA) ;
6 N %,%H,%I,CNT,DATETIME,HLA,HLCS,HLEVN,HLFS,INVPT,ITEM,ITEMDA,ITEMNM
7 N MC,MYOPTION,MYRESULT,ORDRDATA,PRIM,PRIMVN,SEG,X
8 S CNT=0
9 ;
10 ;set up environment for message
111 D INIT^HLFNC2("PRCP EV REL ORDER",.HL)
12 I $G(HL) D Q ; error occurred
13 . W !,"The system can't build an HL7 message now to send your order to"
14 . W !,"the supply station. Please use the 'SO - Send Order' option later."
15 . W !,"Error: "_$P(HL,"^",2)
16 S HLFS=$G(HL("FS")) I HLFS="" S HLFS="|"
17 S HLCS=$E(HL("ECH"),1)
18 ;
19 D NOW^%DTC S DATETIME=(17000000+$P(%,".",1))_$P(%,".",2)
20 ; Add message txt to HLA array
21 ; loop through each item in the order
22 K ^TMP("HLS",$J)
23 S ORDRDATA=^PRCP(445.3,ORDRDA,0)
24 S INVPT=$P(ORDRDATA,"^",3) ; secondary inventory point
25 S PRIM=$P(ORDRDATA,"^",2) ; primary IP
26 S PRIMVN=PRIM_";PRCP(445,"
27 S ITEM=0,CNT=0,USERNAME=""
28 F S ITEM=$O(^PRCP(445.3,ORDRDA,1,ITEM)) Q:'+ITEM D
29 . S CNT=CNT+1
30 . ;
31 . ; create ORC segment
32 . S SEG="ORC"_HL("FS")_"RF" ; RF = order class
33 . S SEG=SEG_HL("FS")_$P(ORDRDATA,"^",1) ; order number
34 . S SEG=SEG_HL("FS")_HL("FS")
35 . S SEG=SEG_"~"_$P(^PRCP(445,INVPT,0),"^",1) ; secondary inventory point
36 . S SEG=SEG_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")
37 . S SEG=SEG_DATETIME_HL("FS")
38 . ; don't send name if vendor doesn't need it
39 . S ^TMP("HLS",$J,CNT)=SEG_USERNAME
40 . ;
41 . ; create RQD Segment
42 . S ITEMNM=$P($G(^PRCP(445,INVPT,1,ITEM,6)),"^",1)
43 . I ITEMNM']"" D ; if no item name, pull from primary or item master
44 . . S X=$P(^PRCP(445.5,$P(^PRCP(445,INVPT,5),"^",1),0),"^",2)
45 . . I X="S" S ITEMNM=$P($G(^PRCP(445,PRIM,1,ITEM,6)),"^",1)
46 . . I X="O" S ITEMNM=$P($G(^PRC(441,ITEM,0)),"^",2)
47 . S CNT=CNT+1
48 . S SEG="RQD"_HL("FS")_HL("FS")_HL("FS")_HL("FS")
49 . S SEG=SEG_ITEM_"~"_ITEMNM
50 . S SEG=SEG_HL("FS")_$P(^PRCP(445.3,ORDRDA,1,ITEM,0),"^",2) ;qty
51 . S SEG=SEG_HL("FS")
52 . S ITEMDA=$P($G(^PRCP(445,PRIM,1,ITEM,0)),"^",5) ; primary unit of issue
53 . I ITEMDA]"" S SEG=SEG_$P($G(^PRCD(420.5,ITEMDA,0)),"^",1) ; unit of issue
54 . I ITEMDA']"" S SEG=SEG_"EA" ; GIP unit of issue default
55 . S ^TMP("HLS",$J,CNT)=SEG
56 . ;
57 . ;NTE (to send conversion factor)
58 . S CNT=CNT+1
59 . S SEG="NTE"_HL("FS")_1_HL("FS")_"RQD"_HL("FS")
60 . I PRIMVN]"" S X=$$GETVEN^PRCPUVEN(INVPT,ITEM,PRIMVN,1)
61 . S SEG=SEG_$P(X,"^",4) ; pkg multiple (conversion factor)
62 . S ITEMDA=$P($G(^PRCP(445,INVPT,1,ITEM,0)),"^",5) ; secondary unit of issue
63 . I ITEMDA]"" S SEG=SEG_"~"_$P($G(^PRCD(420.5,ITEMDA,0)),"^",1) ; SECONDARY ISSUE UNIT
64 . I ITEMDA']"" S SEG=SEG_"EA" ; GIP unit of issue default
65 . S ^TMP("HLS",$J,CNT)=SEG
66 ;
67 ;notify user that message will be sent
68 W !,"ORDER INFORMATION WILL BE TRANSMITTED TO THE SUPPLY STATION."
69 ;
70 ;call HL7 to transmit message
713 S HLL("LINKS",1)="PRCP SU REL ORDER"_"^"_$P(^PRCP(445.5,$P(^PRCP(445,INVPT,5),"^",1),0),"^",3)
72 D GENERATE^HLMA("PRCP EV REL ORDER","GM",1,.MYRESULT,"",.MYOPTION)
73 I $P(MYRESULT,"^",2,3)]"" D
74 . ; error handler for message send failures
75 . W !,"ERROR: ",MYRESULT
76 Q
Note: See TracBrowser for help on using the repository browser.