source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPHLQU.m@ 862

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

initial load of WorldVistAEHR
File size: 6.0 KB
Line 
1PRCPHLQU ;WISC/CC/DWA-Build/receive HL7 messages for QOH queries ;4/00
2V ;;5.1;IFCAP;**1,24,52**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 Q
6 ;
7BLDSEG(INVPT) ;
8 ;
9 N %,%H,%I,CNT,DATETIME,HLA,HLCS,HLEVN,HLFS,MC,MYRESULT,MYOPTNS,SEG
10 S CNT=0
11 I $P($G(^PRCP(445,INVPT,5)),"^",1)']"" Q ; no supply station
12 ;
13 ; set up environment for message
141 D INIT^HLFNC2("PRCP EV QOH REQ",.HL)
15 ; S HLL("LINKS",1)="PRCP EV QOH REQ"_"^"_$P(^PRCP(445.5,$P(^PRCP(445,INVPT,5),"^",1),0),"^",3)
16 I $G(HL) D Q ; error occurred
17 . ; put error handler here for init failure
18 . W !,"HL7 can't build your QOH update request now. Please try later."
19 . W !,"HL7 Error: "_$P(HL,"^",2)
20 S HLFS=$G(HL("FS")) I HLFS="" S HLFS="|"
21 S HLCS=$E(HL("ECH"),1)
22 ;
23 ; Add message txt to HLA array
24 ; create QRD segment
252 D NOW^%DTC S DATETIME=$P(17000000+%,".",1)_$P(%,".",2)
26 S SEG="QRD"_HL("FS")_DATETIME_HL("FS")_"R"_HL("FS")_"D"_HL("FS")_"QOH"_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_"STA"_HL("FS")_HL("FS")_HL("FS")_"S"
27 S HLA("HLS",1)=SEG
28 ;
29 ; create QRF segment
30 S SEG="QRF"_HL("FS")_HL("FS")_DATETIME_HL("FS")_HL("FS")_HL("FS")_"~"_$P(^PRCP(445,INVPT,0),"^",1)
31 S HLA("HLS",2)=SEG
32 ;
33 S HLL("LINKS",1)="PRCP SU QOH REQ"_"^"_$P(^PRCP(445.5,$P(^PRCP(445,INVPT,5),"^",1),0),"^",3)
34 ;
35 ;call HL7 to transmit message
363 D GENERATE^HLMA("PRCP EV QOH REQ","LM",1,.MYRESULT,"",.MYOPTNS)
37 I $P(MYRESULT,"^",2,3)]"" D
38 . ; error handler for message send failures
39 . W !,"ERROR: ",MYRESULT
40 Q
41 ;
42GETMSG(PRCPDA,PRCPDONE) ; receive query information from file 447.1
43 N ITEMDATA,PRCPDATA,PRCPHL7,PRCPITDA,PRCPITEM,PRCPITNM,PRCPLEFT,PRCPQTY,PRCPREP,PRCPSEC,PRCPSITE,PRCPSSFL,PRCPWHEN
44 ;
45 S PRCPDATA=^PRCP(447.1,PRCPDA,0)
46 S PRCPHL7=$P(PRCPDATA,"^",6)_".447.1"
47 S PRCPSITE=$P(PRCPDATA,"^",2)
48 S PRCPSEC=$P(PRCPDATA,"^",3)
49 S PRCPWHEN=$P(PRCPDATA,"^",4)
50 S PRCPREP=0 ; flag to replace current GIP values
51 S PRCPSSFL=$P($G(^PRCP(445.5,$P($G(^PRCP(445,PRCPSEC,5)),"^",1),0)),"^",2)
52 ;
53 L +^PRCP(445,PRCPSEC,7):3 I $T=0 Q
54 D ADD^PRCPULOC(445,PRCPSEC_"-7",0,"HL7 Transaction processing")
55 S PRCPREP=$G(^PRCP(445,PRCPSEC,7))
56 I +PRCPREP=0!($P(PRCPREP,"^",2)]""&($P(PRCPREP,"^",2)'<PRCPWHEN)) D
57 . S PRCPREP=0
58 . L -^PRCP(445,PRCPSEC,7)
59 . D CLEAR^PRCPULOC(445,PRCPSEC_"-7",0)
60 I '$D(^PRCP(445,PRCPSEC)) S ERR="3A" G ERR ; secondary not in GIP
61 I $P(^PRCP(445,PRCPSEC,0),"^",3)'="S" S ERR="3B" G ERR ; not a secondary
62 I $P($G(^PRCP(445,PRCPSEC,5)),"^",1)']"" S ERR="3F" G ERR ; not a supply station secondary
63 S PRCPHLPO("DATE")=PRCPWHEN
64 S PRCPHLPO("REASON")=""
65 S PRCPHLPO("RECIPIENT")=""
66 S PRCPHLPO("USER")=""
67 I PRCPREP'=0 D
68 . N Y
69 . S Y=$P(PRCPREP,"^",2) D DD^%DT
70 . S PRCPHLPO("REASON")=":Authorized "_Y_" by "_$P(^VA(200,+PRCPREP,0),"^",1)
71 . S PRCPHLPO("USER")=$P(PRCPREP,"^",1)
72 . S PRCPHLPO("TRAN")=$$ORDERNO^PRCPUTRX(PRCPSEC)
73 ;
74 S PRCPITDA=0
75LOOP S PRCPITDA=$O(^PRCP(447.1,PRCPDA,1,PRCPITDA)) I '+PRCPITDA G Q
76 S PRCPDATA=^PRCP(447.1,PRCPDA,1,PRCPITDA,0)
77 S PRCPITEM=$P(PRCPDATA,"^",1)
78 S PRCPITNM=$P(PRCPDATA,"^",4)
79 S PRCPLEFT=$P(PRCPDATA,"^",2)
80 I '$D(^PRCP(445,PRCPSEC,1,PRCPITEM,0)) S PRCPQTY(+PRCPITEM)=PRCPLEFT_"^"_PRCPITNM_"^**Not in Inv Pt." G LOOP
81 I $P(^PRCP(445,PRCPSEC,1,PRCPITEM,0),"^",9)'>0 S PRCPQTY(+PRCPITEM)=+PRCPLEFT_"^"_PRCPITNM_"^**Not a SS item" G LOOP
82 I $P($G(^PRC(441,+PRCPITEM,0)),"^",6)="S" S PRCPQTY(+PRCPITEM)=+PRCPLEFT_"^"_PRCPITNM_"^**CC or IK, not SS item" G LOOP
83 ; compare name in 445 with name sent, CONTINUE
84 I PRCPSSFL="O",$P(^PRC(441,PRCPITEM,0),"^",2)'=PRCPITNM D NAME^PRCPHL70(PRCPSEC,PRCPITEM,PRCPITNM,PRCPSSFL,PRCPHL7) ; name differs, send message
85 I PRCPSSFL="S",$G(^PRCP(445,PRCPSEC,1,PRCPITEM,6))'=PRCPITNM D NAME^PRCPHL70(PRCPSEC,PRCPITEM,PRCPITNM,PRCPSSFL,PRCPHL7) ; name differs, send message
86 S PRCPDATA=$G(^PRCP(445,PRCPSEC,1,PRCPITEM,9))
87 I $P(PRCPDATA,"^",2)'>PRCPWHEN D
88 . S $P(PRCPDATA,"^",2)=PRCPWHEN
89 . S $P(PRCPDATA,"^",1)=PRCPLEFT
90 . S ^PRCP(445,PRCPSEC,1,PRCPITEM,9)=PRCPDATA
91 S PRCPHLPO("ITEM")=^PRCP(445,PRCPSEC,1,PRCPITEM,0)
92 I PRCPREP'=0 D
93 . S PRCPHLPO("QTY")=PRCPLEFT-$P(PRCPHLPO("ITEM"),"^",7)
94 . S PRCPHLPO("INVVAL")=$J(PRCPHLPO("QTY")*$P(PRCPHLPO("ITEM"),"^",22),0,2)
95 . S PRCPHLPO("SELVAL")=PRCPHLPO("INVVAL")
96 . D UPDATE^PRCPHL1(PRCPSEC,PRCPITEM,PRCPLEFT,.PRCPHLPO,"Q")
97 I PRCPREP=0,$P(PRCPHLPO("ITEM"),"^",7)'=PRCPLEFT S PRCPQTY(PRCPITEM)=PRCPLEFT_"^"_$P(PRCPHLPO("ITEM"),"^",7)
98 G LOOP
99 ;
100Q N ITEM,ITEMNAME,LN,PRCPXMY,QTYSS,QTYIP,SSTYPE,XMB,XMDUZ,XMTEXT
101 S SSTYPE=$P(^PRCP(445.5,$P(^PRCP(445,PRCPSEC,5),"^",1),0),"^",2)
102 K ^TMP($J,"PRCPHL7")
103 S ITEM=0,LN=1
104 F S ITEM=$O(PRCPQTY(ITEM)) Q:'ITEM D
105 . S ITEMNAME=$P($G(^PRCP(445,PRCPSEC,1,ITEM,6)),"^",1)
106 . I SSTYPE="O" S ITEMNAME=$P(^PRC(441,ITEM,0),"^",2)
107 . S QTYSS=+PRCPQTY(ITEM),QTYIP=+$P(PRCPQTY(ITEM),"^",2)
108 . S ^TMP($J,"PRCPHL7",1,LN,0)=$E(" ",$L(QTYIP)+1,7)_QTYIP_" "_$E(" ",$L(QTYSS)+1,7)_QTYSS_" "_$E(" ",$L(ITEM)+1,7)_ITEM_" "_$E(ITEMNAME,1,30)_" "_$P(PRCPQTY(ITEM),"^",3)
109 . S LN=LN+1
110 I PRCPREP=0,'$O(PRCPQTY(0)) S ^TMP($J,"PRCPHL7",1,1,0)="<no discrepancies found>"
111 I PRCPREP'=0 S ^TMP($J,"PRCPHL7",1,1,0)="<The GIP on-hand quantity has been adjusted to supply station totals>"
112 S ^TMP($J,"PRCPHL7",1)=LN
113 D GETUSER^PRCPXTRM(PRCPSEC) Q:'$O(PRCPXMY("")) ; send message to secondary inventory point managers
114 F S ITEM=$O(PRCPXMY(ITEM)) Q:ITEM'>0 I PRCPXMY(ITEM)=1 S XMY(ITEM)=""
115 S XMTEXT="^TMP($J,""PRCPHL7"",1,"
116 S XMB(1)=$$INVNAME^PRCPUX1(PRCPSEC)
117 S XMB="PRCP_ALL_ITEMS_QTY_UPDATE"
118 S XMDUZ="SUPPLY STATION INTERFACE"
119 D EN^XMB
120 K ^TMP($J,"PRCPHL7")
121 ;
122 S $P(^PRCP(445,PRCPSEC,6),"^",1)=PRCPWHEN
123 I PRCPREP'=0 D
124 . N DIE,DA,DR
125 . L -^PRCP(445,PRCPSEC,7) D CLEAR^PRCPULOC(445,PRCPSEC_"-7",0)
126 . S DIE="^PRCP(445,",DA=PRCPSEC,DR="24////@;25////@" D ^DIE
127 S PRCPDONE=1
128 Q
129 ;
130ERR ;
131 N NUMBER,PRCPXMY
132 S NUMBER=ERR
133 S PRCPHLPO("SIPNAME")="" I $D(PRCPSEC) S PRCPHLPO("SIPNAME")=$$INVNAME^PRCPUX1(PRCPSEC)
134 S PRCPHLPO("ITEM")="" I $D(PRCPITEM) S PRCPHLPO("ITEM")=PRCPITEM
135 S PRCPHLPO("NAME")="" I $D(PRCPITEM) S PRCPHLPO("NAME")=PRCPITNM
136 S PRCPHLPO("LEFT")="" I $D(PRCPLEFT) S PRCPHLPO("LEFT")=PRCPLEFT
137 D ERR^PRCPHLM0(NUMBER,"PRCP_BAD_QUERY",PRCPSEC,.PRCPHLPO,PRCPHL7,"")
138 S PRCPDONE=1
139 Q
Note: See TracBrowser for help on using the repository browser.