Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOHLDIS

PSOHLDIS.m

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