source: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLDIS.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 8.8 KB
Line 
1PSOHLDIS ;BIR/PWC,SAB - Automated Dispense Completion HL7 v.2.4 ;10/20/06 3:39pm
2 ;;7.0;OUTPATIENT PHARMACY;**156,189,193,209,148,259,200**;DEC 1997;Build 7
3 ;Reference to ^PSDRUG supported by DBIA #221
4 ;Reference to $$NDCFMT^PSSNDCUT supported by IA 4707
5 ;This routine is called by FACK1^PSOHLDS
6 ;
7 ;*209 add Drug accountability & fix Copay for refills
8 ;*259 check for refill node to exist before updating the Release msg
9 ;
10EN ;main entry and process
11 N NONODE
12 D GETHL7,GETPID,GETORC,GETRXD
13 ;
14 ;Begin Updating files ;*259
15 I MEDDISP D ;if dispensed
16 . I FLL="F",'FLLN D FILL ;orig fill
17 . I FLL="F",FLLN D REFILL ;refill
18 . I FLL="P" D PARTIAL ;partial fill
19 . D ACTLOG ;activity log
20 . Q:$G(NONODE) ;quit, no refill node to update
21 . I $D(BGRP),$D(BNAM),$D(BDIV) D BINGREL^PSOHLDI1 ;bingo board rel
22 . D DRGACCT^PSOHLDI1(RXID) ;drug accountability *209
23 . I '$G(PRT) D CHKADDR^PSODISPS(RXID)
24 E D ;else not dispensed
25 . D ACTLOG ;activity log no release
26 ;
27 ;if label was printed
28 I PRT D
29 . S LBI=0 F LB=0:0 S LB=$O(^PSRX(RXID,"L",LB)) Q:'LB S LBI=LBI+1
30 . S LBI=LBI+1,^PSRX(RXID,"L",0)="^52.032DA^"_LBI_"^"_LBI
31 . S ^PSRX(RXID,"L",LBI,0)=NOW_"^"_$S(FLL="F":FLLN,1:(99-FLLN))_"^"_"From Rx # "_$P(^PSRX(RXID,0),"^")_$S(FLL="P":" (Partial)",1:"")_$S($G(HLRPT):" (Reprint)",1:"")_" (External Interface)"_"^"_HLUSER
32 ;
33 D END
34 Q
35 ;
36GETHL7 ;get HL7 segments from msg
37 K OK
38 F I=0:0 S I=$O(PSOMSG(I)) Q:'I D
39 .I $P(PSOMSG(I),"|")="MSH" S NODE1=PSOMSG(I) Q
40 .I $P(PSOMSG(I),"|")="MSA" S NODE2=PSOMSG(I) Q
41 .I $P(PSOMSG(I),"|")="PID" S NODE3=PSOMSG(I) Q
42 .I $P(PSOMSG(I),"|")="ORC" S NODE4=PSOMSG(I) Q
43 .I $P(PSOMSG(I),"|")="RXD" S NODE5=PSOMSG(I) Q
44 Q
45 ;
46GETPID ;get PID segment data
47 S PID=$P($G(NODE3),"|",4) ;this contains all the patient id numbers
48 F XX=1:1 S PIDD=$P(PID,"^",XX) Q:PIDD="" D
49 . S PIDID=$P(PIDD,"~",5)
50 . I PIDID="NI" S PICN=$P(PIDD,"~",1) ;ICN #
51 . I PIDID="SS" S PSSN=$P(PIDD,"~",1) ;SSN #
52 . I PIDID="PI" S PPID=$P(PIDD,"~",1) ;patient ID
53 . I PIDID="PN" S PCLM=$P(PIDD,"~",1) ;claim #
54 Q
55GETORC ;get ORC segment data
56 S RXID=$P($P($G(NODE4),"|",3),"^") ;RX #
57 S DFN=$P(^PSRX(RXID,0),"^",2) D DEM^VADPT
58 S NAME=VADM(1),DOB=$P(VADM(3),"^"),SEX=$P(VADM(5),"^") K VADM
59 S FPER=$P($P($G(NODE4),"|",11),"~") ;filling person
60 K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=+FPER D
61 .D ^DIC I +Y>0 S FPER=+Y,FPERN=$P(Y,"^",2) Q
62 .S FPER="",FPERN="UNKNOWN"
63 S CPHARM=$P($P($G(NODE4),"|",12),"~") ;checking pharmacist
64 K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=+CPHARM D K DIC,X,Y
65 .D ^DIC I +Y>0 S CPHARM=+Y,CPHARMN=$P(Y,"^",2) Q
66 .S CPHARM="",CPHARMN="UNKNOWN"
67 Q
68GETRXD ;get RXD segment data
69 S FILL=$P($P($G(NODE5),"|",2),"^") ;fill #
70 S GIVECOD=$P($P($G(NODE5),"|",3),"^") ;give code
71 S X=$P($P($G(NODE5),"|",4),"^"),DISPDT=$$FMDATE^HLFNC(X) K X ;dispense date
72 S PSORX=$P($P($G(NODE5),"|",8),"^") ;prescription #
73 S NDC=$P($P($G(NODE5),"|",10),"^") ;NDC #
74 K F I NDC]"" D K L,F
75 .S F=""
76 .F L=1:1:$L(NDC,"^") I $P(NDC,"^",L)'="" S F=$G(F)_$P(NDC,"^",L)_$S($P(NDC,"^",(L+1))]"":",",1:"")
77 .S NDC=F
78 S X=$P($P($G(NODE5),"|",10),"^",2),RELDT=$S($$FMDATE^HLFNC(X)>0:$$FMDATE^HLFNC(X),1:"") K X ;release dt
79 S PRT=$S($P($P($G(NODE5),"|",10),"^",3)=1:1,$P($P($G(NODE5),"|",10),"^",3)=2:1,1:0) ;label printed by vendor
80 S MEDDISP=$S($P($P($G(NODE5),"|",10),"^",3)=1:1,$P($P($G(NODE5),"|",10),"^",3)=4:1,1:0) ;med dispensed by vendor
81 S RPHARM=$P($P($G(NODE5),"|",11),"~",1) ;releasing pharmacist
82 K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=+RPHARM D
83 .D ^DIC I +Y>0 S RPHARM=+Y Q
84 .S RPHARM=""
85 S LOT=$P($G(NODE5),"|",19)
86 I LOT]"" D K L,F
87 .S F=""
88 .F L=1:1:$L(LOT,"^") I $P(LOT,"^",L)'="" S F=$G(F)_$P(LOT,"^",L)_$S($P(LOT,"^",(L+1))]"":",",1:"")
89 .S LOT=F
90 S X=$P($P($G(NODE5),"|",20),"^"),EXPDT=$S($$FMDATE^HLFNC(X)>0:$$FMDATE^HLFNC(X),1:"") K X ;expiration date
91 S MFG=$P($P($G(NODE5),"|",21),"^") ;manufacturer
92 K F I MFG]"" D K L,F
93 .F L=1:1:$L(MFG) Q:$P(MFG,"^",L)="" S F=$G(F)_$P(MFG,"^",L)_$S($P(MFG,"^",(L+1))]"":",",1:"")
94 .S MFG=F
95 S EXRX=^PS(52.51,EIN,0)
96 S IRX=$P(EXRX,"^"),FLL=$P(EXRX,"^",8),FLLN=$P(EXRX,"^",9),RPT=$P(EXRX,"^",5),(DIV,PSOSITE)=$P(EXRX,"^",11),PSOPAR=$G(^PS(59,DIV,0))
97 S PSOPAR7=$G(^PS(59,PSOSITE,"IB")),PSOSYS=$G(^PS(59.7,1,40.1))
98 S RXN=$P(^PSRX(IRX,0),"^"),DRG=$P(^(0),"^",6),QTY=$P(^(0),"^",7)
99 Q
100FILL ;Orig fill
101 S $P(^PSRX(IRX,2),"^",4)=LOT,$P(^(2),"^",8)=MFG,$P(^(2),"^",11)=EXPDT,$P(^PSRX(IRX,"OR1"),"^",6)=FPER,$P(^("OR1"),"^",7)=CPHARM
102 S:$G(^PSDRUG(DRG,660.1))]"" ^PSDRUG(DRG,660.1)=^PSDRUG(DRG,660.1)-QTY
103 ;if auto release & rel dt
104 I $P($G(^PS(59,DIV,"DISP")),"^",2),$G(RELDT) D
105 .S DIE="^PSRX(",DA=IRX,DR="31///"_RELDT_";23////"_RPHARM_";32.1///@;32.2///@" D ^DIE K DIE,DR,DA
106 .I $P(^PSRX(IRX,0),"^",11)["W" S BRT="W",BNAM=$P(^PSRX(IRX,0),"^",2),BDIV=$P(^(2),"^",9) S:BDIV'="" BGRP=$P($G(^PS(59,BDIV,1)),"^",20)
107 .S PSOCPRX=$P(^PSRX(IRX,0),"^"),RXP=IRX D CP^PSOCP
108 .D EN^PSOHLSN1(IRX,"ZD"),AUTOREL^PSOBPSUT(IRX,FLLN,RELDT,NDC,"A",,30)
109 ;else if not auto release nor rel dt
110 E I $$NDCFMT^PSSNDCUT(NDC)'="",$$STATUS^PSOBPSUT(IRX,FLLN)="" D SAVNDC^PSONDCUT(IRX,FLLN,NDC)
111 Q
112REFILL ;refill
113 I '$D(^PSRX(IRX,1,FLLN,0)) S NONODE=1 Q
114 S $P(^PSRX(IRX,1,FLLN,0),"^",6)=LOT,$P(^(0),"^",14)=MFG,$P(^(0),"^",15)=EXPDT,$P(^(1),"^",4)=FPER,$P(^(1),"^",5)=CPHARM
115 S:$G(^PSDRUG(DRG,660.1))]"" ^PSDRUG(DRG,660.1)=^PSDRUG(DRG,660.1)-$P(^PSRX(IRX,1,FLLN,0),"^",4)
116 I $P($G(^PS(59,DIV,"DISP")),"^",2),$G(RELDT) D
117 .S DIE="^PSRX("_IRX_","""_1_""",",DA(1)=IRX,DA=FLLN
118 .S DR="17///"_RELDT_";4////"_RPHARM D ^DIE K DIE,DR,DA
119 .I $P(^PSRX(IRX,1,FLLN,0),"^",2)["W" S BRT="W",BDIV=$P(^PSRX(IRX,1,FLLN,0),"^",9),BNAM=$P(^PSRX(IRX,0),"^",2) S:BDIV'="" BGRP=$P($G(^PS(59,BDIV,1)),"^",20)
120 .N YY S YY=FLLN ;*209
121 .S PSOCPRX=$P(^PSRX(IRX,0),"^"),RXP=IRX D CP^PSOCP
122 .D EN^PSOHLSN1(IRX,"ZD"),AUTOREL^PSOBPSUT(IRX,FLLN,RELDT,NDC,"A",,30)
123 ;else if not auto release nor rel dt
124 E I $$NDCFMT^PSSNDCUT(NDC)'="",$$STATUS^PSOBPSUT(IRX,FLLN)="" D SAVNDC^PSONDCUT(IRX,FLLN,NDC)
125 Q
126PARTIAL ;partial fill dispensed
127 I '$D(^PSRX(IRX,"P",FLLN,0)) S NONODE=1 Q
128 S $P(^PSRX(IRX,"P",FLLN,0),"^",6)=LOT,$P(^(0),"^",12)=NDC,$P(^PSRX(IRX,"P",FLLN,1),"^")=MFG,$P(^(1),"^",3)=FPER,$P(^(1),"^",4)=CPHARM
129 S:$G(^PSDRUG(DRG,660.1))]"" ^PSDRUG(DRG,660.1)=^PSDRUG(DRG,660.1)-$P(^PSRX(IRX,"P",FLLN,0),"^",4)
130 I $P($G(^PS(59,DIV,"DISP")),"^",2),$G(RELDT) D
131 .S DIE="^PSRX("_IRX_","""_"P"_""",",DA(1)=IRX,DA=FLLN
132 .S DR="8///"_RELDT_";.05////"_RPHARM D ^DIE K DIE,DR,DA
133 .I $P(^PSRX(IRX,"P",FLLN,0),"^",2)["W" S BRT="W",BDIV=$P(^PSRX(IRX,"P",FLLN,0),"^",9),BNAM=$P(^PSRX(IRX,0),"^",2) S:BDIV'="" BGRP=$P($G(^PS(59,BDIV,1)),"^",20)
134 Q
135ACTLOG ;activity log entry
136 N ATXT,ACTN,RXF
137 S:FLL="F" RXF=$S(FLLN>5:FLLN+1,1:FLLN)
138 S:FLL="P" RXF=6
139 S ACL=0 F I=0:0 S I=$O(^PSRX(RXID,"A",I)) Q:'I S ACL=(ACL+1)
140 D NOW^%DTC S NOW=%,ACL=ACL+1,^PSRX(RXID,"A",0)="^52.3DA^"_ACL_"^"_ACL
141 I 'MEDDISP S ATXT="Medication WAS NOT Dispensed through Interface!"
142 ;
143 ;create activity log text
144 I MEDDISP D
145 . S ATXT="External Interface Dispensing is Complete."
146 . I $G(NONODE) D Q ;node was deleted
147 . . S ATXT="External Interface attempted to Release, but "
148 . . S ATXT=ATXT_$S(FLL="P":"Partial fill",1:"Refill")_" NOT on file."
149 . . S ACTN="No update performed."
150 . . D MAIL^PSOHLDI1
151 . I $G(^PSRX(RXID,"STA"))>11 D Q ;non-active status
152 . . S ATXT="Ext. Disp. Released this Rx, which is Status of "
153 . . S ATXT=ATXT_$$GET1^DIQ(52,RXID,100)
154 . . S ACTN=""
155 . . D MAIL^PSOHLDI1
156 S ^PSRX(RXID,"A",ACL,0)=NOW_"^N^"_RPHARM_"^"_RXF_"^"_ATXT
157 ;
158 ;other comments - additional info when dispensed
159 I MEDDISP D
160 .S ^PSRX(RXID,"A",ACL,2,0)="^52.34A^2^2"
161 .S ^PSRX(RXID,"A",ACL,2,1,0)="Filled By: "_FPERN
162 .S ^PSRX(RXID,"A",ACL,2,2,0)="Checking Pharmacist: "_CPHARMN
163 Q
164ERROR ;sends the error message back to the sending station
165 ;parse the data from the msh segment in order to send back the error message release
166 ;OK=1 - segment missing
167 ;OK=2 - Rx does not exists
168 D NOW^%DTC
169 S REJ=$S(OK=1:"MISSING SEGMENT(S)",OK=2:"PRESCRIPTION "_$S($G(PSORX):"#: "_PSORX,1:"")_" DOES NOT EXISTS",1:"")
170 S ACKDATE=$P($$FMTHL7^XLFDT(%),"-",1)
171 S ^TMP("PSO2",$J,1)="MSH|^~\&|PSO VISTA||PSO DISPENSE||"_$G(ACKDATE)_"||RDS^013|10001|P|2.4|||NE|NE"
172 ;S ^TMP("PSO2",$J,2)="MFE|MUP|"_$G(J)_"|"_$G(ACKDATE)_"|"_$G(SITE)_"|CE"
173 ;S ^TMP("PSO2",$J,3)="ZLF|4|^"_$G(USER)_"||"_$G(REJ)
174 K %,ACKDATE,USER,Y,REJ,OK
175 Q
176END K ACL,I,NOW,LBI,LB,PRT,MEDDISP
177 K ADA,BDA,BDIV,BNGRXP,BNGSUS,BNAME,BRX,CNT1,CT,DA,DD,DIC,DIE,DIK,DIR,DO,DR,DTOUT,DUOUT,GRP,GRTP,JOES
178 K NAM,NDA,NFLAG,NME,ODA,PSZ,RXO,SSN,TDFN,TFLAG,TIC,TICK,TIEN,TM,TM1,TSSN,X,Y,XX,BNAM,BRT,BGRP
179 K Y,OK,XQADATA,SITEN,RDOM,CMOP,REQT,RTDTM,SITENUM,XQSOP,XQMSG,SITEN,NAME,XQAMSG,SITEN
180 K XQAROU,XQAID,RDTM,NODE1,NODE2,NODE3,NODE4,NODE5,PIDID,PIDD,PICN,PSSN,PPID,PCLM
181 K CPHARM,CPHARMN,FPER,FPERN,RPHARM
182 Q
Note: See TracBrowser for help on using the repository browser.