source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPHLFM.m@ 1006

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

initial load of WorldVistAEHR

File size: 5.7 KB
Line 
1PRCPHLFM ;WISC/CC/DWA-build HL7 messages for item maintenance ;11/5/03 22:34
2V ;;5.1;IFCAP;**1,24,52,63**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 Q
6 ;
7BLDSEG(ACTION,ITEM,SIP) ;
8 ;
9 ; ACTION (1st '^' piece) 1 if add, 2 if delete, 3 if update
10 ; (2nd '^' piece) flag indicating txn MUST be built
11 ; ITEM the number of the item affected
12 ; SIP the number of the secondary inventory point affected
13 ; 0 (zero) for non-station specific edits (from PRCHE)
14 ; MSG 0 to suppress messages, 1 to display them
15 ;
16 ; if this is a non-station specific edit (i.e. from PRCHE)
17 ;
18 N MSG,PUSH S MSG=1
19 S PUSH=0
20 I $P(ACTION,"^",2)=1 S PUSH=1
21 I ACTION=3,SIP=0 D QUIT
22 . N SS,IME
23 . S SS=0,IME=0 ; entry from PRCHE
24 . F S SS=$O(^PRCP(445.5,SS)) Q:'+SS D
25 . . ; send transaction to non-station specific SS housing the item
26 . . I $P(^PRCP(445.5,SS,0),"^",2)="O",$O(^PRCP(445,"AH",ITEM,SS,""))>0 D GO
27 ;
28 N IME,SS
29 I $P(^PRCP(445,SIP,0),"^",3)'="S" QUIT
30 I '$D(^PRCP(445,SIP,1,ITEM)),ACTION'=2 QUIT
31 S SS=$P($G(^PRCP(445,SIP,5)),"^",1) I SS']"" QUIT
32 S IME=0
33 ;
34GO N %,%H,%I,CNT,DATETIME,HLA,HLCS,HLEVN,HLFS,ITEMDATA,MC,NM,OUT,PRIM,SEG,X
35 N MYRESULT,MYOPTNS
36 I SIP>0,'+$P($G(^PRCP(445,SIP,1,ITEM,0)),"^",9),ACTION'=2 QUIT ; only deletes are valid for items with no normal
37 S CNT=0,OUT=0
38 ; if the supply station doesn't handle station specific data
39 I SS>0,$P(^PRCP(445.5,SS,0),"^",2)="O",'PUSH D I OUT QUIT
40 . ; I ACTION=3 S OUT=1 QUIT ; quit if editing station specific data
41 . ; for add, quit if item is already on an IP in the SS
42 . I ACTION=1 D
43 . . N A,B
44 . . S A=0
45 . . S A=$O(^PRCP(445,"AH",ITEM,SS,"")) I +A'>0 S OUT=1 QUIT ; should have one
46 . . I A'=SIP S OUT=1 QUIT ; item on a different IP in the SS
47 . . I A=SIP S B=$O(^PRCP(445,"AH",ITEM,SS,A)) I +B>0 S OUT=1 QUIT
48 . I ACTION=2 D I OUT=1 QUIT
49 . . N A,B
50 . . S A=0
51 . . S A=$O(^PRCP(445,"AH",ITEM,SS,"")) I +A'>0 QUIT ; should find one
52 . . I A'=SIP S OUT=1 QUIT ; item is on a different IP in the SS, don't delete from system
53 . . I A=SIP S B=$O(^PRCP(445,"AH",ITEM,SS,A)) I +B>0 S OUT=1 QUIT ; item exists on another IP in the SS, don't delete from system
54 . ; S SIP=0 ; flag to indicate revisions are not station specific
55 ;
56 ; set up environment for message
571 D INIT^HLFNC2("PRCP EV ITEM UPDATE",.HL)
58 I $G(HL) D:'IME&MSG Q ; error occurred
59 . D EN^DDIOL("The HL7 transaction cannot be built now.")
60 . I ACTION=1,MSG D EN^DDIOL("You will need to add this item directly to the supply station.")
61 . I ACTION=2,MSG D EN^DDIOL("You will need to delete this item from your supply station.")
62 . I ACTION=3,MSG D EN^DDIOL("You must edit the item again later to update the supply station.")
63 . D EN^DDIOL("Error: "_$P(HL,"^",2))
64 S HLFS=$G(HL("FS")) I HLFS="" S HLFS="|"
65 S HLCS=$E(HL("ECH"),1)
66 ;
67 I MSG D EN^DDIOL("Building HL7 "_($P("ADD,DELETE,EDIT",",",ACTION))_" Transaction on item#"_ITEM_" for "_$P(^PRCP(445.5,SS,0),"^",1))
68 I MSG,SIP>0 D EN^DDIOL(" station "_$P(^PRCP(445,SIP,0),"^",1))
69 ;
70 ; create MFI segment
712 D NOW^%DTC S DATETIME=$P(%+17000000,".",1)_$P(%,".",2)
72 S SEG="MFI"_HL("FS")
73 S SEG=SEG_($S(SIP>0:445,1:441))_HL("FS")_HL("FS")
74 S HLA("HLS",1)=SEG_"UPD"_HL("FS")_DATETIME_HL("FS")_HL("FS")_"NE"
75 ;
76 ; create MFE segment
77 S SEG="MFE"_HL("FS")
78 I ACTION=1 S SEG=SEG_"MAD"
79 I ACTION=2 S SEG=SEG_"MDL"
80 I ACTION=3 S SEG=SEG_"MUP"
81 S SEG=SEG_HL("FS")_HL("FS")_HL("FS")
82 S HLA("HLS",2)=SEG_ITEM_"~"_$P(^PRC(441,ITEM,0),"^",2)
83 ;
84 I SIP'>0 G 3 ; Z segment for station specific items only
85 ;
86 S ITEMDATA=""
87 S ITEMDATA=^PRCP(445,SIP,1,ITEM,0)
88 S PRIM=$P(ITEMDATA,"^",12) I PRIM']"" D
89 . S PRIM=$O(^PRCP(445,"AB",SIP,""))
90 . I PRIM]"" S PRIM=PRIM_";PRCP(445,"
91 S NM=$P($G(^PRCP(445,SIP,1,ITEM,6)),"^",1)
92 I NM']"",+PRIM>0 S NM=$P($G(^PRCP(445,+PRIM,1,ITEM,6)),"^",1)
93 I NM']"" S NM=$P(^PRC(441,ITEM,0),"^",2)
94 ;
95 ; create Z segment
96 S SEG="ZIM"_HL("FS")_ITEM_"~"_NM ; item# and description
97 S SEG=SEG_HL("FS")_"~"_$P(^PRCP(445,SIP,0),"^",1) ; full station name
98 S SEG=SEG_HL("FS")_$P(ITEMDATA,"^",9) ; normal level
99 S SEG=SEG_HL("FS")_$P(ITEMDATA,"^",10) ; std reord pt
100 S SEG=SEG_HL("FS")_$P(ITEMDATA,"^",11)_HL("FS") ; emergency
101 I $P(ITEMDATA,"^",5)]"" S SEG=SEG_$P($G(^PRCD(420.5,$P(ITEMDATA,"^",5),0)),"^",1) ; unit of issue
102 I PRIM]"" S X=$$GETVEN^PRCPUVEN(SIP,ITEM,PRIM,1)
103 S X=$P(X,"^",4) I X']"" S X=1
104 S SEG=SEG_HL("FS")_X ; pkg multiple (conversion factor)
105 S HLA("HLS",3)=SEG_HL("FS")_$P(ITEMDATA,"^",15) ; last cost
106 ;
107 ;call HL7 to transmit message
1083 S HLL("LINKS",1)="PRCP SU ITEM UPDATE"_"^"_$P(^PRCP(445.5,SS,0),"^",3)
109 D GENERATE^HLMA("PRCP EV ITEM UPDATE","LM",1,.MYRESULT,"",.MYOPTNS)
110 I MSG,$P(MYRESULT,"^",2,3)]"" D
111 . ; error handler for message send failures
112 . D EN^DDIOL("ERROR: "_MYRESULT)
113 Q
114 ;
115 ; send all items in IP to supply station
116INIT D ^PRCPUSEL Q:'$G(PRCP("I"))
117 I PRCP("DPTYPE")'="P" W !," This option may only be invoked from the Primary"
118 N ACTION,DIR,DTOUT,DUOUT,INVPT,ITEM,PRCPINPT,Y
119INIT0 S INVPT=$$INVPT^PRCPUINV(PRC("SITE"),"S","","","") Q:'INVPT
120 I $P($G(^PRCP(445,INVPT,5)),"^",1)']"" W !,"This option may only be run for supply station secondary inventory points." G INIT0
121 ;
122 ; ask initialize or update supply station items?
123 S DIR("A",1)="This option sends information about ALL items with a normal stock"
124 S DIR("A",2)="level greater than zero to the linked supply station. "
125 S DIR("A",3)="You must flag the transactions as 'ADD' or 'EDIT'."
126 S DIR("A",4)=""
127 S DIR("A")="Select 'Add' OR 'Edit' transactions"
128 S DIR(0)="SB^A:ADD;E:EDIT"
129 D ^DIR
130 I $D(DUOUT)!($D(DTOUT))!(Y']"") QUIT
131 S ACTION=3 ; default to edit
132 I Y="A" S ACTION=1
133 ;
134 S ITEM=0 F S ITEM=$O(^PRCP(445,INVPT,1,ITEM)) Q:'+ITEM D
135 . I '$D(^PRCP(445,INVPT,1,ITEM,0)) QUIT
136 . I +$P($G(^PRCP(445,INVPT,1,ITEM,0)),"^",9)=0 QUIT
137 . D BLDSEG^PRCPHLFM(ACTION,ITEM,INVPT)
138 . Q
139 Q
Note: See TracBrowser for help on using the repository browser.