- 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 Feb 18, 2025@23:56:11 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