PSOHLDIS ;BIR/PWC,SAB - Automated Dispense Completion HL7 v.2.4 ;8/28/07 5:00pm
;;7.0;OUTPATIENT PHARMACY;**156,189,193,209,148,259,200,330,354**;DEC 1997;Build 16
;Reference to ^PSDRUG supported by DBIA #221
;Reference to $$NDCFMT^PSSNDCUT supported by IA 4707
;This routine is called by FACK1^PSOHLDS
;
;*209 add Drug accountability & fix Copay for refills
;*259 check for refill node to exist before updating the Release msg
;*330 send variable PSOSITE when updating drug accountability
;
EN ;main entry and process
N NONODE
D GETHL7,GETPID,GETORC,GETRXD
;
;Begin Updating files ;*259
I $G(MDUP) D G END ;duplicate entry w tracking information.
.I TRKLOC'="" D ALCOM
I MEDDISP D ;if dispensed
. I FLL="F",'FLLN D FILL ;orig fill
. I FLL="F",FLLN D REFILL ;refill
. I FLL="P" D PARTIAL ;partial fill
. D ACTLOG ;activity log
. Q:$G(NONODE) ;quit, no refill node to update
. I $D(BGRP),$D(BNAM),$D(BDIV) D BINGREL^PSOHLDI1 ;bingo board rel
. D DRGACCT^PSOHLDI1(RXID,PSOSITE) ;drug accountability *209,*330
. I '$G(PRT) D CHKADDR^PSODISPS(RXID)
E D ;else not dispensed
. D ACTLOG ;activity log no release
;
;if label was printed
I PRT D
. S LBI=0 F LB=0:0 S LB=$O(^PSRX(RXID,"L",LB)) Q:'LB S LBI=LBI+1
. S LBI=LBI+1,^PSRX(RXID,"L",0)="^52.032DA^"_LBI_"^"_LBI
. 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
;
D END
Q
;
GETHL7 ;get HL7 segments from msg
K OK
F I=0:0 S I=$O(PSOMSG(I)) Q:'I D
.I $P(PSOMSG(I),"|")="MSH" S NODE1=PSOMSG(I) Q
.I $P(PSOMSG(I),"|")="MSA" S NODE2=PSOMSG(I) Q
.I $P(PSOMSG(I),"|")="PID" S NODE3=PSOMSG(I) Q
.I $P(PSOMSG(I),"|")="ORC" S NODE4=PSOMSG(I) Q
.I $P(PSOMSG(I),"|")="RXD" S NODE5=PSOMSG(I) Q
Q
;
GETPID ;get PID segment data
S PID=$P($G(NODE3),"|",4) ;this contains all the patient id numbers
F XX=1:1 S PIDD=$P(PID,"^",XX) Q:PIDD="" D
. S PIDID=$P(PIDD,"~",5)
. I PIDID="NI" S PICN=$P(PIDD,"~",1) ;ICN #
. I PIDID="SS" S PSSN=$P(PIDD,"~",1) ;SSN #
. I PIDID="PI" S PPID=$P(PIDD,"~",1) ;patient ID
. I PIDID="PN" S PCLM=$P(PIDD,"~",1) ;claim #
Q
GETORC ;get ORC segment data
S RXID=$P($P($G(NODE4),"|",3),"^") ;RX #
S DFN=$P(^PSRX(RXID,0),"^",2) D DEM^VADPT
S NAME=VADM(1),DOB=$P(VADM(3),"^"),SEX=$P(VADM(5),"^") K VADM
S FPER=$P($P($G(NODE4),"|",11),"~") ;filling person
K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=+FPER D
.D ^DIC I +Y>0 S FPER=+Y,FPERN=$P(Y,"^",2) Q
.S FPER="",FPERN="UNKNOWN"
S CPHARM=$P($P($G(NODE4),"|",12),"~") ;checking pharmacist
K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=+CPHARM D K DIC,X,Y
.D ^DIC I +Y>0 S CPHARM=+Y,CPHARMN=$P(Y,"^",2) Q
.S CPHARM="",CPHARMN="UNKNOWN"
Q
GETRXD ;get RXD segment data
S FILL=$P($P($G(NODE5),"|",2),"^") ;fill #
S GIVECOD=$P($P($G(NODE5),"|",3),"^") ;give code
S X=$P($P($G(NODE5),"|",4),"^"),DISPDT=$$FMDATE^HLFNC(X) K X ;dispense date
S PSORX=$P($P($G(NODE5),"|",8),"^") ;prescription #
S NDC=$P($P($G(NODE5),"|",10),"^") ;NDC #
K F I NDC]"" D K L,F
.S F=""
.F L=1:1:$L(NDC,"^") I $P(NDC,"^",L)'="" S F=$G(F)_$P(NDC,"^",L)_$S($P(NDC,"^",(L+1))]"":",",1:"")
.S NDC=F
S X=$P($P($G(NODE5),"|",10),"^",2),RELDT=$S($$FMDATE^HLFNC(X)>0:$$FMDATE^HLFNC(X),1:"") K X ;release dt
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
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
S TRKLOC=$P($G(NODE5),"|",14) ;mail tracking info
S RPHARM=$P($P($G(NODE5),"|",11),"~",1) ;releasing pharmacist
K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=+RPHARM D
.D ^DIC I +Y>0 S RPHARM=+Y Q
.S RPHARM=""
S LOT=$P($G(NODE5),"|",19)
I LOT]"" D K L,F
.S F=""
.F L=1:1:$L(LOT,"^") I $P(LOT,"^",L)'="" S F=$G(F)_$P(LOT,"^",L)_$S($P(LOT,"^",(L+1))]"":",",1:"")
.S LOT=F
S X=$P($P($G(NODE5),"|",20),"^"),EXPDT=$S($$FMDATE^HLFNC(X)>0:$$FMDATE^HLFNC(X),1:"") K X ;expiration date
S MFG=$P($P($G(NODE5),"|",21),"^") ;manufacturer
K F I MFG]"" D K L,F
.F L=1:1:$L(MFG) Q:$P(MFG,"^",L)="" S F=$G(F)_$P(MFG,"^",L)_$S($P(MFG,"^",(L+1))]"":",",1:"")
.S MFG=F
S EXRX=^PS(52.51,EIN,0)
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))
S PSOPAR7=$G(^PS(59,PSOSITE,"IB")),PSOSYS=$G(^PS(59.7,1,40.1))
S RXN=$P(^PSRX(IRX,0),"^"),DRG=$P(^(0),"^",6),QTY=$P(^(0),"^",7)
Q
FILL ;Orig fill
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
S:$G(^PSDRUG(DRG,660.1))]"" ^PSDRUG(DRG,660.1)=^PSDRUG(DRG,660.1)-QTY
;if auto release & rel dt
I $P($G(^PS(59,DIV,"DISP")),"^",2),$G(RELDT) D
.S DIE="^PSRX(",DA=IRX,DR="31///"_RELDT_";23////"_RPHARM_";32.1///@;32.2///@" D ^DIE K DIE,DR,DA
.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)
.S PSOCPRX=$P(^PSRX(IRX,0),"^"),RXP=IRX D CP^PSOCP
.D EN^PSOHLSN1(IRX,"ZD"),AUTOREL^PSOBPSUT(IRX,FLLN,RELDT,NDC,"A",,30)
;else if not auto release nor rel dt
E I $$NDCFMT^PSSNDCUT(NDC)'="",$$STATUS^PSOBPSUT(IRX,FLLN)="" D SAVNDC^PSONDCUT(IRX,FLLN,NDC)
Q
REFILL ;refill
I '$D(^PSRX(IRX,1,FLLN,0)) S NONODE=1 Q
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
S:$G(^PSDRUG(DRG,660.1))]"" ^PSDRUG(DRG,660.1)=^PSDRUG(DRG,660.1)-$P(^PSRX(IRX,1,FLLN,0),"^",4)
I $P($G(^PS(59,DIV,"DISP")),"^",2),$G(RELDT) D
.S DIE="^PSRX("_IRX_","""_1_""",",DA(1)=IRX,DA=FLLN
.S DR="17///"_RELDT_";4////"_RPHARM D ^DIE K DIE,DR,DA
.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)
.N YY S YY=FLLN ;*209
.S PSOCPRX=$P(^PSRX(IRX,0),"^"),RXP=IRX D CP^PSOCP
.D EN^PSOHLSN1(IRX,"ZD"),AUTOREL^PSOBPSUT(IRX,FLLN,RELDT,NDC,"A",,30)
;else if not auto release nor rel dt
E I $$NDCFMT^PSSNDCUT(NDC)'="",$$STATUS^PSOBPSUT(IRX,FLLN)="" D SAVNDC^PSONDCUT(IRX,FLLN,NDC)
Q
PARTIAL ;partial fill dispensed
I '$D(^PSRX(IRX,"P",FLLN,0)) S NONODE=1 Q
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
S:$G(^PSDRUG(DRG,660.1))]"" ^PSDRUG(DRG,660.1)=^PSDRUG(DRG,660.1)-$P(^PSRX(IRX,"P",FLLN,0),"^",4)
I $P($G(^PS(59,DIV,"DISP")),"^",2),$G(RELDT) D
.S DIE="^PSRX("_IRX_","""_"P"_""",",DA(1)=IRX,DA=FLLN
.S DR="8///"_RELDT_";.05////"_RPHARM D ^DIE K DIE,DR,DA
.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)
Q
ACTLOG ;activity log entry
N ATXT,ACTN,RXF
S:FLL="F" RXF=$S(FLLN>5:FLLN+1,1:FLLN)
S:FLL="P" RXF=6
S ACL=0 F I=0:0 S I=$O(^PSRX(RXID,"A",I)) Q:'I S ACL=(ACL+1)
D NOW^%DTC S NOW=%,ACL=ACL+1,^PSRX(RXID,"A",0)="^52.3DA^"_ACL_"^"_ACL
I 'MEDDISP S ATXT="Medication WAS NOT Dispensed through Interface!"
;
;create activity log text
I MEDDISP D
. S ATXT="External Interface Dispensing is Complete."
. I $G(NONODE) D Q ;node was deleted
. . S ATXT="External Interface attempted to Release, but "
. . S ATXT=ATXT_$S(FLL="P":"Partial fill",1:"Refill")_" NOT on file."
. . S ACTN="No update performed."
. . D MAIL^PSOHLDI1
. I $G(^PSRX(RXID,"STA"))>11 D Q ;non-active status
. . S ATXT="Ext. Disp. Released this Rx, which is Status of "
. . S ATXT=ATXT_$$GET1^DIQ(52,RXID,100)
. . S ACTN=""
. . D MAIL^PSOHLDI1
S ^PSRX(RXID,"A",ACL,0)=NOW_"^N^"_RPHARM_"^"_RXF_"^"_ATXT
;
;other comments - additional info when dispensed
I MEDDISP D
.S ^PSRX(RXID,"A",ACL,2,0)="^52.34A^2^2"
.S ^PSRX(RXID,"A",ACL,2,1,0)="Filled By: "_FPERN
.S ^PSRX(RXID,"A",ACL,2,2,0)="Checking Pharmacist: "_CPHARMN
I TRKLOC="" Q
;
ALCOM ;activity log entry - tracking information
N DCNT,I
I $G(ACL)="" S ACL=0 F I=0:0 S I=$O(^PSRX(RXID,"A",I)) Q:'I I $G(^PSRX(RXID,"A",I,2,1,0))["Filled By: " S ACL=I
I 'ACL Q
S DCNT=0 F I=0:0 S I=$O(^PSRX(RXID,"A",ACL,2,I)) Q:'I S DCNT=I
S DCNT=DCNT+1 I $G(NOW)="" D NOW^%DTC S NOW=%
S ^PSRX(RXID,"A",ACL,2,0)="^52.34A^"_DCNT_"^"_DCNT
S ^PSRX(RXID,"A",ACL,2,DCNT,0)="Mail Tracking Info.: "_TRKLOC_" received at "_$$FMTE^XLFDT(NOW,2)
Q
ERROR ;sends the error message back to the sending station
;parse the data from the msh segment in order to send back the error message release
;OK=1 - segment missing
;OK=2 - Rx does not exists
D NOW^%DTC
S REJ=$S(OK=1:"MISSING SEGMENT(S)",OK=2:"PRESCRIPTION "_$S($G(PSORX):"#: "_PSORX,1:"")_" DOES NOT EXISTS",1:"")
S ACKDATE=$P($$FMTHL7^XLFDT(%),"-",1)
S ^TMP("PSO2",$J,1)="MSH|^~\&|PSO VISTA||PSO DISPENSE||"_$G(ACKDATE)_"||RDS^013|10001|P|2.4|||NE|NE"
;S ^TMP("PSO2",$J,2)="MFE|MUP|"_$G(J)_"|"_$G(ACKDATE)_"|"_$G(SITE)_"|CE"
;S ^TMP("PSO2",$J,3)="ZLF|4|^"_$G(USER)_"||"_$G(REJ)
K %,ACKDATE,USER,Y,REJ,OK
Q
END K ACL,I,NOW,LBI,LB,PRT,MEDDISP
K ADA,BDA,BDIV,BNGRXP,BNGSUS,BNAME,BRX,CNT1,CT,DA,DD,DIC,DIE,DIK,DIR,DO,DR,DTOUT,DUOUT,GRP,GRTP,JOES
K NAM,NDA,NFLAG,NME,ODA,PSZ,RXO,SSN,TDFN,TFLAG,TIC,TICK,TIEN,TM,TM1,TSSN,X,Y,XX,BNAM,BRT,BGRP
K Y,OK,XQADATA,SITEN,RDOM,CMOP,REQT,RTDTM,SITENUM,XQSOP,XQMSG,SITEN,NAME,XQAMSG,SITEN
K XQAROU,XQAID,RDTM,NODE1,NODE2,NODE3,NODE4,NODE5,PIDID,PIDD,PICN,PSSN,PPID,PCLM
K CPHARM,CPHARMN,FPER,FPERN,RPHARM,TRKLOC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLDIS 9905 printed Dec 13, 2024@02:29:44 Page 2
PSOHLDIS ;BIR/PWC,SAB - Automated Dispense Completion HL7 v.2.4 ;8/28/07 5:00pm
+1 ;;7.0;OUTPATIENT PHARMACY;**156,189,193,209,148,259,200,330,354**;DEC 1997;Build 16
+2 ;Reference to ^PSDRUG supported by DBIA #221
+3 ;Reference to $$NDCFMT^PSSNDCUT supported by IA 4707
+4 ;This routine is called by FACK1^PSOHLDS
+5 ;
+6 ;*209 add Drug accountability & fix Copay for refills
+7 ;*259 check for refill node to exist before updating the Release msg
+8 ;*330 send variable PSOSITE when updating drug accountability
+9 ;
EN ;main entry and process
+1 NEW NONODE
+2 DO GETHL7
DO GETPID
DO GETORC
DO GETRXD
+3 ;
+4 ;Begin Updating files ;*259
+5 ;duplicate entry w tracking information.
IF $GET(MDUP)
Begin DoDot:1
+6 IF TRKLOC'=""
DO ALCOM
End DoDot:1
GOTO END
+7 ;if dispensed
IF MEDDISP
Begin DoDot:1
+8 ;orig fill
IF FLL="F"
IF 'FLLN
DO FILL
+9 ;refill
IF FLL="F"
IF FLLN
DO REFILL
+10 ;partial fill
IF FLL="P"
DO PARTIAL
+11 ;activity log
DO ACTLOG
+12 ;quit, no refill node to update
if $GET(NONODE)
QUIT
+13 ;bingo board rel
IF $DATA(BGRP)
IF $DATA(BNAM)
IF $DATA(BDIV)
DO BINGREL^PSOHLDI1
+14 ;drug accountability *209,*330
DO DRGACCT^PSOHLDI1(RXID,PSOSITE)
+15 IF '$GET(PRT)
DO CHKADDR^PSODISPS(RXID)
End DoDot:1
+16 ;else not dispensed
IF '$TEST
Begin DoDot:1
+17 ;activity log no release
DO ACTLOG
End DoDot:1
+18 ;
+19 ;if label was printed
+20 IF PRT
Begin DoDot:1
+21 SET LBI=0
FOR LB=0:0
SET LB=$ORDER(^PSRX(RXID,"L",LB))
if 'LB
QUIT
SET LBI=LBI+1
+22 SET LBI=LBI+1
SET ^PSRX(RXID,"L",0)="^52.032DA^"_LBI_"^"_LBI
+23 SET ^PSRX(RXID,"L",LBI,0)=NOW_"^"_$SELECT(FLL="F":FLLN,1:(99-FLLN))_"^"_"From Rx # "_$PIECE(^PSRX(RXID,0),"^")_$SELECT(FLL="P":" (Partial)",1:"")_$SELECT($GET(HLRPT):" (Reprint)",1:"")_" (External Interface)"_"^"_HLUSER
End DoDot:1
+24 ;
+25 DO END
+26 QUIT
+27 ;
GETHL7 ;get HL7 segments from msg
+1 KILL OK
+2 FOR I=0:0
SET I=$ORDER(PSOMSG(I))
if 'I
QUIT
Begin DoDot:1
+3 IF $PIECE(PSOMSG(I),"|")="MSH"
SET NODE1=PSOMSG(I)
QUIT
+4 IF $PIECE(PSOMSG(I),"|")="MSA"
SET NODE2=PSOMSG(I)
QUIT
+5 IF $PIECE(PSOMSG(I),"|")="PID"
SET NODE3=PSOMSG(I)
QUIT
+6 IF $PIECE(PSOMSG(I),"|")="ORC"
SET NODE4=PSOMSG(I)
QUIT
+7 IF $PIECE(PSOMSG(I),"|")="RXD"
SET NODE5=PSOMSG(I)
QUIT
End DoDot:1
+8 QUIT
+9 ;
GETPID ;get PID segment data
+1 ;this contains all the patient id numbers
SET PID=$PIECE($GET(NODE3),"|",4)
+2 FOR XX=1:1
SET PIDD=$PIECE(PID,"^",XX)
if PIDD=""
QUIT
Begin DoDot:1
+3 SET PIDID=$PIECE(PIDD,"~",5)
+4 ;ICN #
IF PIDID="NI"
SET PICN=$PIECE(PIDD,"~",1)
+5 ;SSN #
IF PIDID="SS"
SET PSSN=$PIECE(PIDD,"~",1)
+6 ;patient ID
IF PIDID="PI"
SET PPID=$PIECE(PIDD,"~",1)
+7 ;claim #
IF PIDID="PN"
SET PCLM=$PIECE(PIDD,"~",1)
End DoDot:1
+8 QUIT
GETORC ;get ORC segment data
+1 ;RX #
SET RXID=$PIECE($PIECE($GET(NODE4),"|",3),"^")
+2 SET DFN=$PIECE(^PSRX(RXID,0),"^",2)
DO DEM^VADPT
+3 SET NAME=VADM(1)
SET DOB=$PIECE(VADM(3),"^")
SET SEX=$PIECE(VADM(5),"^")
KILL VADM
+4 ;filling person
SET FPER=$PIECE($PIECE($GET(NODE4),"|",11),"~")
+5 KILL DIC,X,Y
SET DIC="^VA(200,"
SET DIC(0)="N,Z"
SET X=+FPER
Begin DoDot:1
+6 DO ^DIC
IF +Y>0
SET FPER=+Y
SET FPERN=$PIECE(Y,"^",2)
QUIT
+7 SET FPER=""
SET FPERN="UNKNOWN"
End DoDot:1
+8 ;checking pharmacist
SET CPHARM=$PIECE($PIECE($GET(NODE4),"|",12),"~")
+9 KILL DIC,X,Y
SET DIC="^VA(200,"
SET DIC(0)="N,Z"
SET X=+CPHARM
Begin DoDot:1
+10 DO ^DIC
IF +Y>0
SET CPHARM=+Y
SET CPHARMN=$PIECE(Y,"^",2)
QUIT
+11 SET CPHARM=""
SET CPHARMN="UNKNOWN"
End DoDot:1
KILL DIC,X,Y
+12 QUIT
GETRXD ;get RXD segment data
+1 ;fill #
SET FILL=$PIECE($PIECE($GET(NODE5),"|",2),"^")
+2 ;give code
SET GIVECOD=$PIECE($PIECE($GET(NODE5),"|",3),"^")
+3 ;dispense date
SET X=$PIECE($PIECE($GET(NODE5),"|",4),"^")
SET DISPDT=$$FMDATE^HLFNC(X)
KILL X
+4 ;prescription #
SET PSORX=$PIECE($PIECE($GET(NODE5),"|",8),"^")
+5 ;NDC #
SET NDC=$PIECE($PIECE($GET(NODE5),"|",10),"^")
+6 KILL F
IF NDC]""
Begin DoDot:1
+7 SET F=""
+8 FOR L=1:1:$LENGTH(NDC,"^")
IF $PIECE(NDC,"^",L)'=""
SET F=$GET(F)_$PIECE(NDC,"^",L)_$SELECT($PIECE(NDC,"^",(L+1))]"":",",1:"")
+9 SET NDC=F
End DoDot:1
KILL L,F
+10 ;release dt
SET X=$PIECE($PIECE($GET(NODE5),"|",10),"^",2)
SET RELDT=$SELECT($$FMDATE^HLFNC(X)>0:$$FMDATE^HLFNC(X),1:"")
KILL X
+11 ;label printed by vendor
SET PRT=$SELECT($PIECE($PIECE($GET(NODE5),"|",10),"^",3)=1:1,$PIECE($PIECE($GET(NODE5),"|",10),"^",3)=2:1,1:0)
+12 ;med dispensed by vendor
SET MEDDISP=$SELECT($PIECE($PIECE($GET(NODE5),"|",10),"^",3)=1:1,$PIECE($PIECE($GET(NODE5),"|",10),"^",3)=4:1,1:0)
+13 ;mail tracking info
SET TRKLOC=$PIECE($GET(NODE5),"|",14)
+14 ;releasing pharmacist
SET RPHARM=$PIECE($PIECE($GET(NODE5),"|",11),"~",1)
+15 KILL DIC,X,Y
SET DIC="^VA(200,"
SET DIC(0)="N,Z"
SET X=+RPHARM
Begin DoDot:1
+16 DO ^DIC
IF +Y>0
SET RPHARM=+Y
QUIT
+17 SET RPHARM=""
End DoDot:1
+18 SET LOT=$PIECE($GET(NODE5),"|",19)
+19 IF LOT]""
Begin DoDot:1
+20 SET F=""
+21 FOR L=1:1:$LENGTH(LOT,"^")
IF $PIECE(LOT,"^",L)'=""
SET F=$GET(F)_$PIECE(LOT,"^",L)_$SELECT($PIECE(LOT,"^",(L+1))]"":",",1:"")
+22 SET LOT=F
End DoDot:1
KILL L,F
+23 ;expiration date
SET X=$PIECE($PIECE($GET(NODE5),"|",20),"^")
SET EXPDT=$SELECT($$FMDATE^HLFNC(X)>0:$$FMDATE^HLFNC(X),1:"")
KILL X
+24 ;manufacturer
SET MFG=$PIECE($PIECE($GET(NODE5),"|",21),"^")
+25 KILL F
IF MFG]""
Begin DoDot:1
+26 FOR L=1:1:$LENGTH(MFG)
if $PIECE(MFG,"^",L)=""
QUIT
SET F=$GET(F)_$PIECE(MFG,"^",L)_$SELECT($PIECE(MFG,"^",(L+1))]"":",",1:"")
+27 SET MFG=F
End DoDot:1
KILL L,F
+28 SET EXRX=^PS(52.51,EIN,0)
+29 SET IRX=$PIECE(EXRX,"^")
SET FLL=$PIECE(EXRX,"^",8)
SET FLLN=$PIECE(EXRX,"^",9)
SET RPT=$PIECE(EXRX,"^",5)
SET (DIV,PSOSITE)=$PIECE(EXRX,"^",11)
SET PSOPAR=$GET(^PS(59,DIV,0))
+30 SET PSOPAR7=$GET(^PS(59,PSOSITE,"IB"))
SET PSOSYS=$GET(^PS(59.7,1,40.1))
+31 SET RXN=$PIECE(^PSRX(IRX,0),"^")
SET DRG=$PIECE(^(0),"^",6)
SET QTY=$PIECE(^(0),"^",7)
+32 QUIT
FILL ;Orig fill
+1 SET $PIECE(^PSRX(IRX,2),"^",4)=LOT
SET $PIECE(^(2),"^",8)=MFG
SET $PIECE(^(2),"^",11)=EXPDT
SET $PIECE(^PSRX(IRX,"OR1"),"^",6)=FPER
SET $PIECE(^("OR1"),"^",7)=CPHARM
+2 if $GET(^PSDRUG(DRG,660.1))]""
SET ^PSDRUG(DRG,660.1)=^PSDRUG(DRG,660.1)-QTY
+3 ;if auto release & rel dt
+4 IF $PIECE($GET(^PS(59,DIV,"DISP")),"^",2)
IF $GET(RELDT)
Begin DoDot:1
+5 SET DIE="^PSRX("
SET DA=IRX
SET DR="31///"_RELDT_";23////"_RPHARM_";32.1///@;32.2///@"
DO ^DIE
KILL DIE,DR,DA
+6 IF $PIECE(^PSRX(IRX,0),"^",11)["W"
SET BRT="W"
SET BNAM=$PIECE(^PSRX(IRX,0),"^",2)
SET BDIV=$PIECE(^(2),"^",9)
if BDIV'=""
SET BGRP=$PIECE($GET(^PS(59,BDIV,1)),"^",20)
+7 SET PSOCPRX=$PIECE(^PSRX(IRX,0),"^")
SET RXP=IRX
DO CP^PSOCP
+8 DO EN^PSOHLSN1(IRX,"ZD")
DO AUTOREL^PSOBPSUT(IRX,FLLN,RELDT,NDC,"A",,30)
End DoDot:1
+9 ;else if not auto release nor rel dt
+10 IF '$TEST
IF $$NDCFMT^PSSNDCUT(NDC)'=""
IF $$STATUS^PSOBPSUT(IRX,FLLN)=""
DO SAVNDC^PSONDCUT(IRX,FLLN,NDC)
+11 QUIT
REFILL ;refill
+1 IF '$DATA(^PSRX(IRX,1,FLLN,0))
SET NONODE=1
QUIT
+2 SET $PIECE(^PSRX(IRX,1,FLLN,0),"^",6)=LOT
SET $PIECE(^(0),"^",14)=MFG
SET $PIECE(^(0),"^",15)=EXPDT
SET $PIECE(^(1),"^",4)=FPER
SET $PIECE(^(1),"^",5)=CPHARM
+3 if $GET(^PSDRUG(DRG,660.1))]""
SET ^PSDRUG(DRG,660.1)=^PSDRUG(DRG,660.1)-$PIECE(^PSRX(IRX,1,FLLN,0),"^",4)
+4 IF $PIECE($GET(^PS(59,DIV,"DISP")),"^",2)
IF $GET(RELDT)
Begin DoDot:1
+5 SET DIE="^PSRX("_IRX_","""_1_""","
SET DA(1)=IRX
SET DA=FLLN
+6 SET DR="17///"_RELDT_";4////"_RPHARM
DO ^DIE
KILL DIE,DR,DA
+7 IF $PIECE(^PSRX(IRX,1,FLLN,0),"^",2)["W"
SET BRT="W"
SET BDIV=$PIECE(^PSRX(IRX,1,FLLN,0),"^",9)
SET BNAM=$PIECE(^PSRX(IRX,0),"^",2)
if BDIV'=""
SET BGRP=$PIECE($GET(^PS(59,BDIV,1)),"^",20)
+8 ;*209
NEW YY
SET YY=FLLN
+9 SET PSOCPRX=$PIECE(^PSRX(IRX,0),"^")
SET RXP=IRX
DO CP^PSOCP
+10 DO EN^PSOHLSN1(IRX,"ZD")
DO AUTOREL^PSOBPSUT(IRX,FLLN,RELDT,NDC,"A",,30)
End DoDot:1
+11 ;else if not auto release nor rel dt
+12 IF '$TEST
IF $$NDCFMT^PSSNDCUT(NDC)'=""
IF $$STATUS^PSOBPSUT(IRX,FLLN)=""
DO SAVNDC^PSONDCUT(IRX,FLLN,NDC)
+13 QUIT
PARTIAL ;partial fill dispensed
+1 IF '$DATA(^PSRX(IRX,"P",FLLN,0))
SET NONODE=1
QUIT
+2 SET $PIECE(^PSRX(IRX,"P",FLLN,0),"^",6)=LOT
SET $PIECE(^(0),"^",12)=NDC
SET $PIECE(^PSRX(IRX,"P",FLLN,1),"^")=MFG
SET $PIECE(^(1),"^",3)=FPER
SET $PIECE(^(1),"^",4)=CPHARM
+3 if $GET(^PSDRUG(DRG,660.1))]""
SET ^PSDRUG(DRG,660.1)=^PSDRUG(DRG,660.1)-$PIECE(^PSRX(IRX,"P",FLLN,0),"^",4)
+4 IF $PIECE($GET(^PS(59,DIV,"DISP")),"^",2)
IF $GET(RELDT)
Begin DoDot:1
+5 SET DIE="^PSRX("_IRX_","""_"P"_""","
SET DA(1)=IRX
SET DA=FLLN
+6 SET DR="8///"_RELDT_";.05////"_RPHARM
DO ^DIE
KILL DIE,DR,DA
+7 IF $PIECE(^PSRX(IRX,"P",FLLN,0),"^",2)["W"
SET BRT="W"
SET BDIV=$PIECE(^PSRX(IRX,"P",FLLN,0),"^",9)
SET BNAM=$PIECE(^PSRX(IRX,0),"^",2)
if BDIV'=""
SET BGRP=$PIECE($GET(^PS(59,BDIV,1)),"^",20)
End DoDot:1
+8 QUIT
ACTLOG ;activity log entry
+1 NEW ATXT,ACTN,RXF
+2 if FLL="F"
SET RXF=$SELECT(FLLN>5:FLLN+1,1:FLLN)
+3 if FLL="P"
SET RXF=6
+4 SET ACL=0
FOR I=0:0
SET I=$ORDER(^PSRX(RXID,"A",I))
if 'I
QUIT
SET ACL=(ACL+1)
+5 DO NOW^%DTC
SET NOW=%
SET ACL=ACL+1
SET ^PSRX(RXID,"A",0)="^52.3DA^"_ACL_"^"_ACL
+6 IF 'MEDDISP
SET ATXT="Medication WAS NOT Dispensed through Interface!"
+7 ;
+8 ;create activity log text
+9 IF MEDDISP
Begin DoDot:1
+10 SET ATXT="External Interface Dispensing is Complete."
+11 ;node was deleted
IF $GET(NONODE)
Begin DoDot:2
+12 SET ATXT="External Interface attempted to Release, but "
+13 SET ATXT=ATXT_$SELECT(FLL="P":"Partial fill",1:"Refill")_" NOT on file."
+14 SET ACTN="No update performed."
+15 DO MAIL^PSOHLDI1
End DoDot:2
QUIT
+16 ;non-active status
IF $GET(^PSRX(RXID,"STA"))>11
Begin DoDot:2
+17 SET ATXT="Ext. Disp. Released this Rx, which is Status of "
+18 SET ATXT=ATXT_$$GET1^DIQ(52,RXID,100)
+19 SET ACTN=""
+20 DO MAIL^PSOHLDI1
End DoDot:2
QUIT
End DoDot:1
+21 SET ^PSRX(RXID,"A",ACL,0)=NOW_"^N^"_RPHARM_"^"_RXF_"^"_ATXT
+22 ;
+23 ;other comments - additional info when dispensed
+24 IF MEDDISP
Begin DoDot:1
+25 SET ^PSRX(RXID,"A",ACL,2,0)="^52.34A^2^2"
+26 SET ^PSRX(RXID,"A",ACL,2,1,0)="Filled By: "_FPERN
+27 SET ^PSRX(RXID,"A",ACL,2,2,0)="Checking Pharmacist: "_CPHARMN
End DoDot:1
+28 IF TRKLOC=""
QUIT
+29 ;
ALCOM ;activity log entry - tracking information
+1 NEW DCNT,I
+2 IF $GET(ACL)=""
SET ACL=0
FOR I=0:0
SET I=$ORDER(^PSRX(RXID,"A",I))
if 'I
QUIT
IF $GET(^PSRX(RXID,"A",I,2,1,0))["Filled By: "
SET ACL=I
+3 IF 'ACL
QUIT
+4 SET DCNT=0
FOR I=0:0
SET I=$ORDER(^PSRX(RXID,"A",ACL,2,I))
if 'I
QUIT
SET DCNT=I
+5 SET DCNT=DCNT+1
IF $GET(NOW)=""
DO NOW^%DTC
SET NOW=%
+6 SET ^PSRX(RXID,"A",ACL,2,0)="^52.34A^"_DCNT_"^"_DCNT
+7 SET ^PSRX(RXID,"A",ACL,2,DCNT,0)="Mail Tracking Info.: "_TRKLOC_" received at "_$$FMTE^XLFDT(NOW,2)
+8 QUIT
ERROR ;sends the error message back to the sending station
+1 ;parse the data from the msh segment in order to send back the error message release
+2 ;OK=1 - segment missing
+3 ;OK=2 - Rx does not exists
+4 DO NOW^%DTC
+5 SET REJ=$SELECT(OK=1:"MISSING SEGMENT(S)",OK=2:"PRESCRIPTION "_$SELECT($GET(PSORX):"#: "_PSORX,1:"")_" DOES NOT EXISTS",1:"")
+6 SET ACKDATE=$PIECE($$FMTHL7^XLFDT(%),"-",1)
+7 SET ^TMP("PSO2",$JOB,1)="MSH|^~\&|PSO VISTA||PSO DISPENSE||"_$GET(ACKDATE)_"||RDS^013|10001|P|2.4|||NE|NE"
+8 ;S ^TMP("PSO2",$J,2)="MFE|MUP|"_$G(J)_"|"_$G(ACKDATE)_"|"_$G(SITE)_"|CE"
+9 ;S ^TMP("PSO2",$J,3)="ZLF|4|^"_$G(USER)_"||"_$G(REJ)
+10 KILL %,ACKDATE,USER,Y,REJ,OK
+11 QUIT
END KILL ACL,I,NOW,LBI,LB,PRT,MEDDISP
+1 KILL ADA,BDA,BDIV,BNGRXP,BNGSUS,BNAME,BRX,CNT1,CT,DA,DD,DIC,DIE,DIK,DIR,DO,DR,DTOUT,DUOUT,GRP,GRTP,JOES
+2 KILL NAM,NDA,NFLAG,NME,ODA,PSZ,RXO,SSN,TDFN,TFLAG,TIC,TICK,TIEN,TM,TM1,TSSN,X,Y,XX,BNAM,BRT,BGRP
+3 KILL Y,OK,XQADATA,SITEN,RDOM,CMOP,REQT,RTDTM,SITENUM,XQSOP,XQMSG,SITEN,NAME,XQAMSG,SITEN
+4 KILL XQAROU,XQAID,RDTM,NODE1,NODE2,NODE3,NODE4,NODE5,PIDID,PIDD,PICN,PSSN,PPID,PCLM
+5 KILL CPHARM,CPHARMN,FPER,FPERN,RPHARM,TRKLOC
+6 QUIT
