source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPHLQ.m@ 1742

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

initial load of FOIAVistA 6/30/08 version

File size: 5.8 KB
Line 
1PRCPHLQ ;WISC/CC - PROCESS HL7 QOH TRANSACTIONS FROM SUPPLY STATION; 4/00
2V ;;5.1;IFCAP;**1**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 N DA,DIC,DIE,DIK,DLAYGO,DR,ERR,I,J,LNCNT,NUMBER,X,Y,WARN
6 N PRCP7,PRCPDATA,PRCPHL,PRCPITEM,PRCPLEFT,PRCPOC,PRCPSEC,PRCPSECN
7 N PRCPSITE,PRCPTIME,PRCPTXN,PRCPUSER
8 S PRCPTXN=0,PRCPSEC="",LNCNT=1
9 ;
10 ;
11OSR I HL("MTN")'="OSR" S ERR="1B" G ERR ; wrong message name
12 X HLNEXT I HLQUIT'>0 S ERR="1A" G ERR ; missing MSH segment
13 S PRCPHL(LNCNT)=HLNODE,LNCNT=LNCNT+1
14 X HLNEXT I HLQUIT'>0 S ERR="1A" G ERR ; missing segments
15 S PRCPHL(LNCNT)=HLNODE,J=0,LNCNT=LNCNT+1,I=1
16 S X=$$FLD^HLCSUTL(HLNODE,1)
17 I X'="MSA" S ERR="1A" G ERR ; wrong segment name
18 S X=$$FLD^HLCSUTL(HLNODE,2)
19 I X="AE"!(X="AR") S ERR="1F" G ERR ; supply station trouble
20 ;
21 X HLNEXT I HLQUIT'>0 S ERR="1A" G ERR ; missing segments
22 S PRCPHL(LNCNT)=HLNODE,J=0,LNCNT=LNCNT+1,I=1
23 S X=$$FLD^HLCSUTL(HLNODE,1)
24 ;
25 F G:$D(ERR) ERR Q:X'="ERR" D ; can build user message from ERR segs
26 . X HLNEXT I HLQUIT'>0 S ERR="1A",X="OUT" Q ; missing segments
27 . S PRCPHL(LNCNT)=HLNODE,J=0,LNCNT=LNCNT+1,I=1
28 . S X=$$FLD^HLCSUTL(HLNODE,1)
29 ;
30 I X'="QRD" S ERR="1A" G ERR ; wrong segment name
31 ;
32QRD ; QRD SEGMENT
33 I $$FLD^HLCSUTL(HLNODE,3)'="R"!($$FLD^HLCSUTL(HLNODE,4)'="D")!($$FLD^HLCSUTL(HLNODE,5)'="QOH")!($$FLD^HLCSUTL(HLNODE,10)'="STA") S ERR="1E" G ERR
34 S J=$$FLD^HLCSUTL(HLNODE,13) I J]"",J'="S" S ERR="1E" G ERR
35 ;
36 X HLNEXT I HLQUIT'>0 S ERR="1A" G ERR ; missing segments
37 S PRCPHL(LNCNT)=HLNODE,J=0,LNCNT=LNCNT+1,I=1
38 I $$FLD^HLCSUTL(HLNODE,1)'="ORC" S ERR="1A" G ERR ; wrong segment name
39 D ORC I $D(ERR) G ERR
40 ;
41 X HLNEXT I HLQUIT'>0 S ERR="1A" G ERR ; missing segments
42 ;
43LOOP S PRCPHL(LNCNT)=HLNODE,J=0,LNCNT=LNCNT+1,I=1
44 I $$FLD^HLCSUTL(HLNODE,1)'="NTE" S ERR="1A" G ERR ; wrong segment name
45NTE ; READ NTE SEGMENT
46 S PRCPDATA=$$FLD^HLCSUTL(HLNODE,4) ; ID~NAME~QTY
47 S PRCPITEM=$P(PRCPDATA,$E(HL("ECH"),1),1,2)
48 I $P(PRCPITEM,$E(HL("ECH"),1),1)'=+PRCPITEM!(+PRCPITEM=0) D WARN X HLNEXT G Q:HLQUIT'>0 K WARN G LOOP ; item number invalid
49 I '$D(^PRC(441,+PRCPITEM,0)) D WARN X HLNEXT G Q:HLQUIT'>0 K WARN G LOOP ; item number not in file 441
50 ; I '$D(^PRCP(445,PRCPSECN,1,$P(PRCPITEM,$E(HL("ECH"),1),1))) S ERR="6C" G ERR
51 ; I $P(^PRCP(445,PRCPSECN,1,$P(PRCPITEM,$E(HL("ECH"),1),1),0),"^",9)'>0 S ERR="6D" G ERR ; is item a supply station item
52 S PRCPLEFT=$P(PRCPDATA,$E(HL("ECH"),1),3)
53 I +PRCPLEFT'=PRCPLEFT!(PRCPLEFT>999999)!(PRCPLEFT<-999999) S ERR=5 G ERR
54 D PROCESS I $D(ERR) G ERR
55 ;
56 X HLNEXT I HLQUIT'>0 G Q
57 G LOOP
58 ;
59 ; ORC SEGMENT
60ORC S PRCPOC=$$FLD^HLCSUTL(HLNODE,2)
61 S PRCPSEC=$$FLD^HLCSUTL(HLNODE,5)
62 ;
63 I PRCPOC'="OK" S ERR="1C" Q ; order control wrong
64 ;
65 ; get site and IP information
66 I PRCPSEC']"" S ERR="3A" Q
67 S PRCPSEC=$P(PRCPSEC,$E(HL("ECH"),1),2)
68 S PRCPSITE=$P(PRCPSEC,"-",1)
69 I PRCPSITE']"" S ERR="3E" Q
70 I '$D(^PRC(411,PRCPSITE,0)) S ERR="3D" Q ; wrong site
71 S DIC="^PRCP(445,",DIC(0)="X",X=PRCPSEC,PRCPPRIV=1
72 D ^DIC K DIC
73 I Y=-1 S ERR="3A" Q ; secondary not in GIP
74 S PRCPSECN=$P(Y,"^",1)
75 I PRCPSECN']"" S ERR="3A" Q
76 I $P(^PRCP(445,PRCPSECN,0),"^",3)'="S" S ERR="3B" Q ; not a secondary
77 ;
78 S PRCPTIME=$$FLD^HLCSUTL(HLNODE,10)
79 S PRCPTIME=$$FMDATE^HLFNC(PRCPTIME)
80 S PRCPUSER=$$FLD^HLCSUTL(HLNODE,11)
81 S PRCPUSER=$$FMNAME^HLFNC(PRCPUSER)
82 Q
83 ;
84WARN N ITEM,PRCPXMY,XMB,XMDUZ,XMY
85 D GETUSER^PRCPXTRM(PRCPSECN) Q:'$O(PRCPXMY("")) ; send to secondary inventory point managers
86 S ITEM=0
87 F S ITEM=$O(PRCPXMY(ITEM)) Q:ITEM'>0 I PRCPXMY(ITEM)=1 S XMY(ITEM)=""
88 S XMB(1)=PRCPSEC
89 S XMB(2)=PRCPITEM
90 S XMB(3)=HLMTIENS_"."_HLMTIEN
91 S XMB="PRCP_BAD_ITEM_QOH"
92 S XMDUZ="SUPPLY STATION INTERFACE"
93 D EN^XMB
94 Q
95 ;
96PROCESS N %,%H,%I,DA,PRCPHL7,PRCPITNM,PRCPTXNT,PRCPMGTP,DIC,DIE,DR,N,T,X,Y
97 I 'PRCPTXN D I $D(ERR) Q
98 . S X="PRCPHL7TXN"
99 . I $D(^PRCS(410.1,"B",X)) D I $D(ERR) Q
100 . . S N="",N=$O(^PRCS(410.1,"B",X,N)),DA=N
101 . . L +^PRCS(410.1,DA):15 I $T=0 S ERR=198
102 . . S T=$P(^PRCS(410.1,N,0),"^",2)+1 S:T<1 T=1
103 . I '$D(^PRCS(410.1,"B",X)) D I $D(ERR) Q
104 . . S T=1,DLAYGO=410.1,DIC="^PRCS(410.1,",DIC(0)="FLXZ"
105 . . D ^DIC K DLAYGO I Y<0 S ERR=199
106 . . S DA=+Y
107 . . L +^PRCS(410.1,DA):15 I $T=0 S ERR=198
108 . S $P(^PRCS(410.1,DA,0),"^",2)=+T
109 . S $P(^PRCS(410.1,DA,0),"^",3)=DT
110 . L -^PRCS(410.1,DA)
111 . ;
112 . S X=T
113 . S DIC="^PRCP(447.1,"
114 . S DIC(0)="L"
115 . S DLAYGO=447.1
116 . D ^DIC K DIC,DLAYGO
117 . I Y=-1 S ERR=100 Q
118 . I $P(Y,"^",3)'=1 S ERR=101 Q
119 . S (DA,PRCPTXN)=Y+0
120 . L +^PRCP(447.1,DA):3 I $T=0 S ERR=102 Q
121 . S DIE="^PRCP(447.1,"
122 . S DA=PRCPTXN
123 . D NOW^%DTC
124 . S PRCPTXNT=%
125 . S PRCPMGTP=HL("MTN")_HL("ETN")
126 . S PRCPHL7=HLMTIENS_"."_HLMTIEN
127 . S DR="1///^S X=PRCPSITE;2///^S X=PRCPSECN;3///^S X=PRCPTXNT;4///^S X=PRCPMGTP;5///^S X=PRCPHL7;8///^S X=PRCPTIME"
128 . D ^DIE
129 . K DIE,DR
130 S DIC="^PRCP(447.1,"_PRCPTXN_",1,"
131 S DA(1)=PRCPTXN
132 S DIC(0)="L"
133 S DLAYGO=447.1
134 S DIC("P")=$P(^DD(447.1,7,0),"^",2)
135 S X=$P(PRCPITEM,$E(HL("ECH"),1),1)
136 S PRCPSET="I 1" ; over rides screen to omit finding case carts/IK's
137 D ^DIC K DIC,DA,DLAYGO
138 I Y=-1 S ERR=110 Q
139 I $P(Y,"^",3)'=1 S PRCPLEFT=PRCPLEFT+$P($G(^PRCP(447.1,PRCPTXN,1,+Y,0)),"^",2) ; add quantity for an item in different bins
140 S DIE="^PRCP(447.1,"_PRCPTXN_",1,"
141 S DA=+Y
142 S PRCPITNM=$P(PRCPITEM,$E(HL("ECH"),1),2)
143 S DR="1///^S X=PRCPLEFT;3///^S X=PRCPITNM"
144 D ^DIE K DIC,DIE,DR
145 Q
146 ;
147ERR ;
148 I $D(ERR) S NUMBER=ERR
149 I $D(WARN) S NUMBER=WARN
150 S PRCP7("SIPNAME")="AN UNKNOWN INVENTORY POINT"
151 I $D(PRCPSEC),PRCPSEC]"" S PRCP7("SIPNAME")=PRCPSEC
152 I '$D(PRCPSECN) S PRCPSECN=0
153 S PRCP7("ITEM")=""
154 I $D(PRCPITEM) S PRCP7("ITEM")=$P(PRCPITEM,$E(HL("ECH"),1),1)
155 S PRCP7("NAME")=""
156 I $D(PRCPITEM) S PRCP7("NAME")=$P(PRCPITEM,$E(HL("ECH"),1),2)
157 S PRCP7("LEFT")="" I $D(PRCPLEFT) S PRCP7("LEFT")=PRCPLEFT
158 D ERR^PRCPHLM0(NUMBER,"PRCP_BAD_QUERY",PRCPSECN,.PRCP7,HLMTIENS_"."_HLMTIEN,.PRCPHL)
159 I ERR,PRCPTXN S DA=PRCPTXN,DIK="^PRCP(447.1," D ^DIK
160 ;
161Q I PRCPTXN L -^PRCP(447.1,PRCPTXN)
162 Q
Note: See TracBrowser for help on using the repository browser.