PSOHLDS ;BIR/PWC-HL7 V.2.4 AUTOMATED DISPENSE INTERFACE ;03/01/96 09:45
;;7.0;OUTPATIENT PHARMACY;**156,312,354,531,603,643**;DEC 1997;Build 35
;External reference to GETAPP^HLCS2 supported by DBIA 2887
;External reference to INIT^HLFNC2 supported by DBIA 2161
;External reference to GENERATE^HLMA supported by DBIA 2164
;External reference to SETUP^XQALERT supported by DBIA 10081
;External reference to ^XUSEC("PSOINTERFACE" supported by DBIA 10076
;External reference to ^ORD(101 supported by DBIA 872
;External reference to ^PSDRUG supported by DBIA 221
;
INIT ;initialize variables and build outgoing message
N DFLAG,HLRESLT,HLP,PSLINK,PSOHLSER,PSOHLCL,PSOHLINX,DDNS,PSOENH,PSOADD,ADDCAT,PSOMES,OPADD,OPNAM,PSOFNHL7
S PSOHLINX=$$GETAPP^HLCS2("PSO EXT SERVER") Q:$P($G(PSOHLINX),"^",2)="i"
K ^TMP("PSO",$J),^TMP("PSOADD",$J)
S PIEN=$O(^ORD(101,"B","PSO EXT SERVER",0)) G:'PIEN EXIT
S PSI=1,HLPDT=DT D INIT^HLFNC2(PIEN,.HL1) I $G(HL1) G EXIT
S FS=HL1("FS"),HL1("ECH")="~^\&",HLECH=HL1("ECH")
S CS=$E(HL1("ECH")),RS=$E(HL1("ECH"),2),EC=$E(HL1("ECH"),3),SCS=$E(HL1("ECH"),4)
I '$G(PSODTM) D NOW^%DTC S DTME=%
I $G(PSODTM) S DTME=PSODTM
S DDNS=$$GET1^DIQ(59,PSOSITE_",",2006)
S PSOENH=0 D GETDEV,ALLADD
F II=0:0 S II=$O(^UTILITY($J,"PSOHL",II)) Q:'II S ODR=^UTILITY($J,"PSOHL",II) D
.S IRXN=$P(ODR,"^"),IDGN=$P(ODR,"^",2),FP=$P(ODR,"^",3),FPN=$P(ODR,"^",4),DAW=$P(ODR,"^",5),DIN=$P(ODR,"^",6)
.S ^TMP("PSOMID",$J,II)=IRXN_"^"_FP_"^"_FPN I DIN=1 D ;;*312 - ADDED IRXN AS 4TH PIECE
..F JJ=0:0 S JJ=$O(^UTILITY($J,"PSOHL",II,JJ)) Q:'JJ S ING(JJ)=^UTILITY($J,"PSOHL",II,JJ)
.S SDI=$P(ODR,"^",7) I SDI=1 S DRI=^UTILITY($J,"PSOHL",II,"DRI")
.S CPY=$P(ODR,"^",8),RPRT=$P(ODR,"^",9),PRSN=$P(ODR,"^",10),DIV=$G(PSOSITE),DFN=$P(^PSRX(IRXN,0),"^",2),STPMTR=$P($G(^PS(59,DIV,1)),"^",30)
.I $G(STPMTR)>1&($P($G(^PSRX(IRXN,"STA")),"^")=5) D
..N PSOHLSPZ,PSOHLNDA S PSOHLSPZ=$O(^PS(52.5,"B",IRXN,0)),PSOHLNDA=""
..I PSOHLSPZ S PSOHLNDA=$G(^PS(52.5,PSOHLSPZ,0))
..I $G(RXPR(IRXN)),+$G(RXPR(IRXN))'=$P(PSOHLNDA,"^",5) Q
..I '$G(RXRP(IRXN)),'$G(RXPR(IRXN)),$D(RXFL(IRXN)),$P(PSOHLNDA,"^",13)'="",$P($G(RXFL(IRXN)),"^")'=$P(PSOHLNDA,"^",13) Q
..D SUS^PSOLBL4(IRXN,FP,FPN,RPRT)
.S PSOADD=""
.I PSOENH D CHKCAT I PSOADD="" Q
.I PSOADD="" S PSOADD=DDNS
.D LOGMSG
.S PSI=$P(OPADD(PSOADD),"^",2) I PSI="" S PSI=1 K PAS,PAS1,PAS2,PAS3
.D START^PSOHLDS1
.M ^TMP("PSOADD",$J,PSOADD)=^TMP("PSO",$J) S $P(OPADD(PSOADD),"^",2)=PSI
.I $D(ADDCAT("S")) D STRAGE
.K ^TMP("PSO",$J)
I $D(ADDCAT("S")) D MORSTG
S PSLINK=$O(^UTILITY($J,"PSOHL",0))
S DDNS="" F S DDNS=$O(^TMP("PSOADD",$J,DDNS)) Q:DDNS="" D
.K ^TMP("HLS",$J)
.M ^TMP("HLS",$J)=^TMP("PSOADD",$J,DDNS)
.S DPORT=$P(OPADD(DDNS),"^")
.K HLP,HLMID,HLERR,HLRESLT
.S HLP("CONTPTR")="",HLP("SUBSCRIBER")="^^^^~"_DDNS_":"_DPORT_"~DNS"
.D GENERATE^HLMA(PIEN,"GM",1,.HLRESLT,"",.HLP)
.K HLL S HLMID=$P($G(HLRESLT),"^"),HLERR=$P($G(HLRESLT),"^",2)
.I '$G(HLMID) S XQAMSG="Error transmitting "_$P(^DPT(DFN,0),"^")_" order to external interface"_$S(PSOENH:" TO "_DDNS,1:"") D ALERT Q
.I $G(HLMID),$P($G(HLERR),"^")'="" S XQAMSG="Error transmitting batch "_HLMID_" to the external interface"_$S(PSOENH:" TO "_DDNS,1:""),MESS="TRANSMISSION FAILED"_$S(PSOENH:" TO "_DDNS,1:""),STA=3 D UFILE,ALERT Q
.I $G(HLMID),$P($G(HLERR),"^")="" S MESS="MESSAGE TRANSMITTED"_$S(PSOENH:" TO "_$G(OPNAM(DDNS))_" ("_DDNS_")",1:""),STA=1 D UFILE
G EXIT
LOGMSG ;build status of message in log file (#52.51)
N PSODEV,PSOMES,STR
S PSODEV=PSOADD
D LOGBLD
S $P(^TMP("PSOMID",$J,II),"^",4)=PSOMES
;build message for the storage devices
I PSOENH D
.S PSODEV="" F S PSODEV=$O(ADDCAT("S",PSODEV)) Q:PSODEV="" I PSODEV'=PSOADD D
..D LOGBLD
..S STR=$P(^TMP("PSOMID",$J,II),"^",4),STR=$S(STR'="":STR_";",1:"")_PSOMES
..S $P(^TMP("PSOMID",$J,II),"^",4)=STR
Q
LOGBLD ;audit log file #52.51
N DIK,DIC,DA,DD,DO
S DIC="^PS(52.51,",X=IRXN,DIC(0)=""
S DIC("DR")="2////"_DFN_";3////"_DTME_";4////"_PRSN_";5////"_RPRT_";6////"_STPMTR_";8////"_FP_";9////"_FPN_";15////"_DIV_";13////"_"BUILDING MESSAGE"_$S(PSOENH:" TO SEND TO "_PSODEV,1:"")_";14////1"
D FILE^DICN K DD,DO,DIC
S PSOMES=$P(Y,"^")
K Y
Q
UFILE F II=0:0 S II=$O(^TMP("PSOMID",$J,II)) Q:'II S III=$G(^(II)) D
.S PRXX=$P(III,"^",4),PFP=$P(III,"^",2),PFPN=$P(III,"^",3)
.F XX=1:1 S PRX=$P(PRXX,";",XX) Q:PRX="" D
..Q:'$D(^PS(52.51,PRX))
..I $P($G(^PS(52.51,PRX,0)),"^",8)=PFP,$P($G(^PS(52.51,PRX,0)),"^",9)=PFPN D
...I PSOENH,$G(^PS(52.51,PRX,1))'[DDNS Q
...S DA=PRX,DIE="^PS(52.51,",DR="10////"_HLMID_";13////"_MESS_";14////"_STA_"" D ^DIE
...I PSOENH D ACLOG
Q
;
EXIT S:$D(ZTQUEUED) ZTREQ="@"
K ^TMP("PSOMID",$J),MESS,PSODTM,STA,HLMID,PRX,PFP,PFPN,CS,CPY,DAW,DIN,DRI,EC,FP,FPN,FS,ING,IRXN,IDGN,II,JJ,ODR,PSI,RS,SCS,SDI,%
K DA,DIE,DIV,DR,DTME,HL1,HLERR,HLPDT,XXX,DFN,PAS,STPMTR,X,III,PIEN,PRSN,RPRT,PAS1,PAS2,PAS3,PRXX,XX,J
K ^TMP("HLS",$J),^TMP("PSO",$J),^TMP("PSOADD",$J)
Q
;
ERRMSG S EMSG=""
F AA=1:1 X HLNEXT Q:HLQUIT'>0 S EMSG=EMSG_"&&"_HLNODE
S ^TMP("PSO2",$J)=EMSG
Q
ACK ;process MSA received from the dispense machine (client)
;
S:'$D(HL("APAT")) HL("APAT")="AL"
S AACK=HL("APAT"),DTM=HL("DTM"),ETN=HL("ETN"),CMID=HL("MID")
S MTN=HL("MTN"),RAN=HL("RAN"),SAN=HL("SAN"),VER=HL("VER")
S EID=HL("EID"),EIDS=HL("EIDS"),FS=HL("FS")
I $G(VER)'="2.4" G EXT
N ORC K PSOMSG F I=1:1 X HLNEXT Q:HLQUIT'>0 S PSOMSG(I)=HLNODE,J=0 D
.I $P(PSOMSG(I),"|")="MSA" S MSACDE=$P(PSOMSG(I),"|",2),SMID=$P(PSOMSG(I),"|",3) S:$P(PSOMSG(I),"|",4)]"" ERRMSG=$P(PSOMSG(I),"|",4)
.I $P(PSOMSG(I),"|")="ORC" S ORC="1^"_+$P(PSOMSG(I),"|",3)
.I $P(PSOMSG(I),"|")="RXD" S PSOFNHL7=$P(PSOMSG(I),"|",2)
.F S J=$O(HLNODE(J)) Q:'J S PSOMSG(I,J)=HLNODE(J)
;
I SMID'="",$D(^PSRXR(52.09,"F",SMID)) G ACK^PSORLLLI
S ^TMP("PSO1",$J,CMID)=CMID_"^"_AACK_"^"_DTM_"^"_ETN_"^"_MTN_"^"_RAN_"^"_SAN_"^"_VER_"^"_EID_"^"_EIDS
;
S (DIV1,SP1,SP2)="" F S DIV1=$O(^PS(52.51,"AM",SMID,DIV1)) Q:'DIV1 F S SP1=$O(^PS(52.51,"AM",SMID,DIV1,SP1)) Q:'SP1!(SP1=2) S SP2=$P($G(^PS(52.51,SP1,0)),"^",6)
I '$D(MSACDE) G EXT
I $G(MSACDE)="AA" D ACK1
I $G(MSACDE)="AE"!$G(MSACDE)="AR" D ACK2
;
EXT ;
K ^TMP("PSO1",$J),AACK,DTM,ETN,CMID,MTN,RAN,SAN,VER,EID,EIDS,FS,MSA,AA,RPT
K MSA1,MSACDE,SMID,ERRMSG,DIV1,SP1,SP2,HL,UID,FLL,FLLN,IRX,FLD12,FLD13
K DIE,EMSG,HLQUIT,HLNEXT,HLNODE,PSOMSG,ORC,EIN
Q
;
ACK1 ;
S FLD13=$S($G(ORC):"MEDICATION DISPENSED",1:"TO BE PROCESSED") D FACK1
Q
;
ACK2 S XQAMSG="Error processing batch "_SMID_". Interface will continue to transmit.",FLD13="PROCESS FAILED" S:$G(ERRMSG) FLD12=ERRMSG
D FACK2,ALERT
Q
;
ALERT ;send alert to key holders
K XQA,XQAOPT,XQAROU,XQAID,XQADATA,XQAFLAG
F UID=0:0 S UID=$O(^XUSEC("PSOINTERFACE",UID)) Q:'UID S XQA(UID)=""
D SETUP^XQALERT
Q
UDFILE ;updates from vendor
S (DIV1,SP1)="" F S DIV1=$O(^PS(52.51,"AM",SMID,DIV1)) Q:'DIV1 F S SP1=$O(^PS(52.51,"AM",SMID,DIV1,SP1)) Q:'SP1 S (EIN,DA)=SP1 D
.S DIE="^PS(52.51,",DR="7////"_SAN_";11////"_CMID_";13////"_FLD13_";14////2" D ^DIE
Q
FACK1 ;
N RX,RXNA,RXNAQ,RXDIV
D:'$G(ORC) UDFILE
I $G(ORC) D
. S RXNAQ=0,RXNA=$P(ORC,"^",2)
. ; Trying to match via MESSAGE SERVER ID (HL7) - Should always find a match
. I SMID'="" D
. . S RXDIV="" F S RXDIV=$O(^PS(52.51,"AM",SMID,RXDIV)) Q:(('RXDIV)!(RXNAQ)) D
. . . S RX="" F S RX=$O(^PS(52.51,"AM",SMID,RXDIV,RX)) Q:(('RX)!(RXNAQ)) D
. . . . I $$GET1^DIQ(52.51,RX,.01,"I")=RXNA S (EIN,DA)=RX,RXNAQ=1
. ; Trying to match with a REGULAR Fill (Non-Partials) - 'Fail Safe' matching logic
. I '$G(DA) D
. . S RX="" F S RX=$O(^PS(52.51,"B",RXNA,RX),-1) Q:(('RX)!(RXNAQ)) D
. . . I $$GET1^DIQ(52.51,RX,8,"I")="P" Q ; Partial Fill
. . . I $$GET1^DIQ(52.51,RX,9,"I")=PSOFNHL7 S (EIN,DA)=RX,RXNAQ=1
. ; Trying to match with a PARTIAL Fill (OPAI returns either 0 or 1 for Partial Fill #) - 'Fail Safe' matching logic
. I '$G(DA) D
. . S RX="" F S RX=$O(^PS(52.51,"B",RXNA,RX),-1) Q:(('RX)!(RXNAQ)) D
. . . I $$GET1^DIQ(52.51,RX,8,"I")'="P" Q ; Regular Fill
. . . S (EIN,DA)=RX,RXNAQ=1
. I $G(DA) D
. . I $P($G(^PS(52.51,DA,1)),"^",4)="MEDICATION DISPENSED",$P(^PS(52.51,DA,0),"^",10)=2 S MDUP=1 D ^PSOHLDIS K EIN,MDUP Q
. . S HLUSER=$P(^PS(52.51,DA,0),"^",4),HLRPT=$P(^(0),"^",5)
. . S DIE="^PS(52.51,",DR="7////"_SAN_";11////"_CMID_";13////"_FLD13_";14////2" D ^DIE,^PSOHLDIS K EIN,HLUSER,HLRPT
Q
;
FACK2 ;
D UDFILE Q:'$G(^PSRX($P(^PS(52.51,EIN,0),"^"),0))
S ACL=0,IRX=$P(^PS(52.51,EIN,0),"^"),FLL=$P(^(0),"^",8),FLLN=$P(^(0),"^",9),RXN=$P(^PSRX(IRX,0),"^")
F I=0:0 S SUB=$O(^PSRX(IRX,"A",I)) Q:'I S ACL=(ACL+1)
D NOW^%DTC S ACL=ACL+1,^PSRX(IRX,"A",0)="^52.3DA^"_ACL_"^"_ACL
S ^PSRX(IRX,"A",ACL,0)=%_"^N^^"_$S(FLL="F":FLLN,1:(99-FLLN))_"^External Interface Rx NOT Dispensed." K ACL,I,RXN
Q
;
GETDEV ;get devices associated with dispensing printer
;Create array OPADD & ADDCAT
; Output: OPADD(dns)=port
; ADDCAT(category,dns)=""
;
N DDNS,DPORT,PIO,PN,DN,DEV,DAT,DAT1
K OPADD,ADDCAT
S PN=$G(^UTILITY($J,"PSOPAI")),PIO=$O(^PS(59,PSOSITE,"P","B",+PN,""))
S DN=$O(^PS(59,PSOSITE,"P",+PIO,"OPAI",0))
I ('PIO)!(DN="") D Q
.S DDNS=$$GET1^DIQ(59,PSOSITE_",",2006),DPORT=$$GET1^DIQ(59,PSOSITE_",",2007),OPADD(DDNS)=DPORT
S PSOENH=1,DEV=0 F S DEV=$O(^PS(59,PSOSITE,"P",PIO,"OPAI",DEV)) Q:'DEV D
.S DAT=$G(^PS(59,PSOSITE,"P",PIO,"OPAI",DEV,0)) I $P(DAT,"^",2)="" Q
.S DAT1=$$ADDCHK($P(DAT,"^")) I DAT1 D
..S OPADD($P(DAT1,"^",3))=$P(DAT1,"^",4),ADDCAT($P(DAT,"^",2),$P(DAT1,"^",3))=""
Q
;
CHKCAT ;checks the ADD category to determine if and where the prescription should be routed.
N PDAT,DRG,DRG0,DDEV,RTE,CSB,MTH,DEV53
S PSOADD=""
I $G(PSONEADS) S DRG=PSOLDRUG,RTE=$E($G(PSOHLSV("ROUTING")))
I '$G(PSONEADS) S PDAT=$G(^PSRX(IRXN,0)),DRG=$P(PDAT,"^",6),RTE=$$RTE()
S DRG0=$G(^PSDRUG(+DRG,0)),DDEV=$G(^PSDRUG(DRG,"OPAI",PSOSITE,0))
I DDEV'="" S DEV53=$$ADDCHK($S(RTE="W":$P(DDEV,"^",2),RTE="M":$P(DDEV,"^",3),1:"")) I DEV53 D Q
.I $D(OPADD($P(DEV53,"^",3))) S PSOADD=$P(DEV53,"^",3) Q
.S OPADD($P(DEV53,"^",3))=$P(DEV53,"^",4),PSOADD=$P(DEV53,"^",3)
I $D(ADDCAT("A")) S PSOADD=$O(ADDCAT("A","")) Q
S CSB=+$P(DRG0,"^",3),CSB=$S((CSB>0)&(CSB<6):"CS",1:"NCS")
I $D(ADDCAT(CSB)) S PSOADD=$O(ADDCAT(CSB,"")) Q
I $D(ADDCAT(RTE_CSB)) S PSOADD=$O(ADDCAT(RTE_CSB,"")) Q
S MTH=$S(RTE="W":"WIND",RTE="M":"MAIL",1:"") I MTH'="",$D(ADDCAT(MTH)) S PSOADD=$O(ADDCAT(MTH,"")) Q
I $D(ADDCAT("S")) S PSOADD=$O(ADDCAT("S","")) Q
Q
;
STRAGE ;set HL7 entries in ^TMP global to be sent to the storage device.
N DNS,CNT,CNT1,STR
S DNS=$O(ADDCAT("S","")) I DNS="" Q
I DNS=PSOADD Q
I '$D(^TMP("PSOADD",$J,DNS)) D Q
.M ^TMP("PSOADD",$J,DNS)=^TMP("PSO",$J) S $P(OPADD(DNS),"^",2)=PSI
S CNT=0 F S CNT=$O(^TMP("PSO",$J,CNT)) Q:'CNT D
.S STR=$G(^TMP("PSO",$J,CNT))
.I "^PID^PV1^PV2^IAM^"[("^"_$E(STR,1,3)_"^") Q
.S CNT1=+$P(OPADD(DNS),"^",2)
.M ^TMP("PSOADD",$J,DNS,CNT1)=^TMP("PSO",$J,CNT)
.S CNT1=CNT1+1,$P(OPADD(DNS),"^",2)=CNT1
Q
MORSTG ;if more than one storage device is defined, add the others to the ^TMP global
N RDNS,DNS
S DNS=$O(ADDCAT("S","")) I DNS="" Q
S RDNS=DNS F S RDNS=$O(ADDCAT("S",RDNS)) Q:RDNS="" D
.M ^TMP("PSOADD",$J,RDNS)=^TMP("PSOADD",$J,DNS)
Q
;
ADDCHK(DEV) ;check ADD in file #52.53 and return status and the zero node
; 1 - valid or 0 - invalid
I $G(DEV)="" Q 0
N DEVD
S DEVD=$G(^PS(52.53,DEV,0))
I ($P(DEVD,"^")="")!($P(DEVD,"^",2)="")!($P(DEVD,"^",3)="") Q 0_"^"_DEVD
I $P(DEVD,"^",4),$P(DEVD,"^",4)'>DT Q 0_"^"_DEVD
Q 1_"^"_DEVD
;
ALLADD ;get all active ADDs in #52.53
; OPNAM(dns)=dns name
N X,XD
K OPNAM
S X=0 F S X=$O(^PS(52.53,X)) Q:'X D
.S XD=$G(^PS(52.53,X,0))
.Q:($P(XD,"^")="")!($P(XD,"^",2)="")!($P(XD,"^",3)="")
.I $P(XD,"^",4),$P(XD,"^",4)'>DT Q
.I $G(PSONECT) S PSONECTC=PSONECTC+1
.S OPNAM($P(XD,"^",2))=$P(XD,"^")
Q
;
ACLOG ;activity log (HL7 message transmitted to the interface)
N DTTM,HCOM,HCNT,HJJ,IEN52
S IEN52=$P($G(^PS(52.51,PRX,0)),"^")
D NOW^%DTC S DTTM=%,HCOM=MESS
S HCNT=0 F HJJ=0:0 S HJJ=$O(^PSRX(IEN52,"A",HJJ)) Q:'HJJ S HCNT=HJJ
S HCNT=HCNT+1,^PSRX(IEN52,"A",0)="^52.3DA^"_HCNT_"^"_HCNT S ^PSRX(IEN52,"A",HCNT,0)=DTTM_"^X^"_$S($G(PDUZ):PDUZ,1:.5)_"^"_"^"_$S($G(HLMID):"HL7 ID - "_HLMID,1:"")_" "_HCOM
Q
RTE() ;get RX route
N MW
I $G(FP)="F"&('$G(FPN)) S MW=$P($G(^PSRX(IRXN,0)),"^",11) ;original
I $G(FP)="F"&($G(FPN)) S MW=$P($G(^PSRX(IRXN,1,FPN,0)),"^",2) ;refill
I $G(FP)="P"&($G(FPN)) S MW=$P($G(^PSRX(IRXN,"P",FPN,0)),"^",2) ;partial
Q $G(MW)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLDS 12642 printed Sep 23, 2025@20:06:10 Page 2
PSOHLDS ;BIR/PWC-HL7 V.2.4 AUTOMATED DISPENSE INTERFACE ;03/01/96 09:45
+1 ;;7.0;OUTPATIENT PHARMACY;**156,312,354,531,603,643**;DEC 1997;Build 35
+2 ;External reference to GETAPP^HLCS2 supported by DBIA 2887
+3 ;External reference to INIT^HLFNC2 supported by DBIA 2161
+4 ;External reference to GENERATE^HLMA supported by DBIA 2164
+5 ;External reference to SETUP^XQALERT supported by DBIA 10081
+6 ;External reference to ^XUSEC("PSOINTERFACE" supported by DBIA 10076
+7 ;External reference to ^ORD(101 supported by DBIA 872
+8 ;External reference to ^PSDRUG supported by DBIA 221
+9 ;
INIT ;initialize variables and build outgoing message
+1 NEW DFLAG,HLRESLT,HLP,PSLINK,PSOHLSER,PSOHLCL,PSOHLINX,DDNS,PSOENH,PSOADD,ADDCAT,PSOMES,OPADD,OPNAM,PSOFNHL7
+2 SET PSOHLINX=$$GETAPP^HLCS2("PSO EXT SERVER")
if $PIECE($GET(PSOHLINX),"^",2)="i"
QUIT
+3 KILL ^TMP("PSO",$JOB),^TMP("PSOADD",$JOB)
+4 SET PIEN=$ORDER(^ORD(101,"B","PSO EXT SERVER",0))
if 'PIEN
GOTO EXIT
+5 SET PSI=1
SET HLPDT=DT
DO INIT^HLFNC2(PIEN,.HL1)
IF $GET(HL1)
GOTO EXIT
+6 SET FS=HL1("FS")
SET HL1("ECH")="~^\&"
SET HLECH=HL1("ECH")
+7 SET CS=$EXTRACT(HL1("ECH"))
SET RS=$EXTRACT(HL1("ECH"),2)
SET EC=$EXTRACT(HL1("ECH"),3)
SET SCS=$EXTRACT(HL1("ECH"),4)
+8 IF '$GET(PSODTM)
DO NOW^%DTC
SET DTME=%
+9 IF $GET(PSODTM)
SET DTME=PSODTM
+10 SET DDNS=$$GET1^DIQ(59,PSOSITE_",",2006)
+11 SET PSOENH=0
DO GETDEV
DO ALLADD
+12 FOR II=0:0
SET II=$ORDER(^UTILITY($JOB,"PSOHL",II))
if 'II
QUIT
SET ODR=^UTILITY($JOB,"PSOHL",II)
Begin DoDot:1
+13 SET IRXN=$PIECE(ODR,"^")
SET IDGN=$PIECE(ODR,"^",2)
SET FP=$PIECE(ODR,"^",3)
SET FPN=$PIECE(ODR,"^",4)
SET DAW=$PIECE(ODR,"^",5)
SET DIN=$PIECE(ODR,"^",6)
+14 ;;*312 - ADDED IRXN AS 4TH PIECE
SET ^TMP("PSOMID",$JOB,II)=IRXN_"^"_FP_"^"_FPN
IF DIN=1
Begin DoDot:2
+15 FOR JJ=0:0
SET JJ=$ORDER(^UTILITY($JOB,"PSOHL",II,JJ))
if 'JJ
QUIT
SET ING(JJ)=^UTILITY($JOB,"PSOHL",II,JJ)
End DoDot:2
+16 SET SDI=$PIECE(ODR,"^",7)
IF SDI=1
SET DRI=^UTILITY($JOB,"PSOHL",II,"DRI")
+17 SET CPY=$PIECE(ODR,"^",8)
SET RPRT=$PIECE(ODR,"^",9)
SET PRSN=$PIECE(ODR,"^",10)
SET DIV=$GET(PSOSITE)
SET DFN=$PIECE(^PSRX(IRXN,0),"^",2)
SET STPMTR=$PIECE($GET(^PS(59,DIV,1)),"^",30)
+18 IF $GET(STPMTR)>1&($PIECE($GET(^PSRX(IRXN,"STA")),"^")=5)
Begin DoDot:2
+19 NEW PSOHLSPZ,PSOHLNDA
SET PSOHLSPZ=$ORDER(^PS(52.5,"B",IRXN,0))
SET PSOHLNDA=""
+20 IF PSOHLSPZ
SET PSOHLNDA=$GET(^PS(52.5,PSOHLSPZ,0))
+21 IF $GET(RXPR(IRXN))
IF +$GET(RXPR(IRXN))'=$PIECE(PSOHLNDA,"^",5)
QUIT
+22 IF '$GET(RXRP(IRXN))
IF '$GET(RXPR(IRXN))
IF $DATA(RXFL(IRXN))
IF $PIECE(PSOHLNDA,"^",13)'=""
IF $PIECE($GET(RXFL(IRXN)),"^")'=$PIECE(PSOHLNDA,"^",13)
QUIT
+23 DO SUS^PSOLBL4(IRXN,FP,FPN,RPRT)
End DoDot:2
+24 SET PSOADD=""
+25 IF PSOENH
DO CHKCAT
IF PSOADD=""
QUIT
+26 IF PSOADD=""
SET PSOADD=DDNS
+27 DO LOGMSG
+28 SET PSI=$PIECE(OPADD(PSOADD),"^",2)
IF PSI=""
SET PSI=1
KILL PAS,PAS1,PAS2,PAS3
+29 DO START^PSOHLDS1
+30 MERGE ^TMP("PSOADD",$JOB,PSOADD)=^TMP("PSO",$JOB)
SET $PIECE(OPADD(PSOADD),"^",2)=PSI
+31 IF $DATA(ADDCAT("S"))
DO STRAGE
+32 KILL ^TMP("PSO",$JOB)
End DoDot:1
+33 IF $DATA(ADDCAT("S"))
DO MORSTG
+34 SET PSLINK=$ORDER(^UTILITY($JOB,"PSOHL",0))
+35 SET DDNS=""
FOR
SET DDNS=$ORDER(^TMP("PSOADD",$JOB,DDNS))
if DDNS=""
QUIT
Begin DoDot:1
+36 KILL ^TMP("HLS",$JOB)
+37 MERGE ^TMP("HLS",$JOB)=^TMP("PSOADD",$JOB,DDNS)
+38 SET DPORT=$PIECE(OPADD(DDNS),"^")
+39 KILL HLP,HLMID,HLERR,HLRESLT
+40 SET HLP("CONTPTR")=""
SET HLP("SUBSCRIBER")="^^^^~"_DDNS_":"_DPORT_"~DNS"
+41 DO GENERATE^HLMA(PIEN,"GM",1,.HLRESLT,"",.HLP)
+42 KILL HLL
SET HLMID=$PIECE($GET(HLRESLT),"^")
SET HLERR=$PIECE($GET(HLRESLT),"^",2)
+43 IF '$GET(HLMID)
SET XQAMSG="Error transmitting "_$PIECE(^DPT(DFN,0),"^")_" order to external interface"_$SELECT(PSOENH:" TO "_DDNS,1:"")
DO ALERT
QUIT
+44 IF $GET(HLMID)
IF $PIECE($GET(HLERR),"^")'=""
SET XQAMSG="Error transmitting batch "_HLMID_" to the external interface"_$SELECT(PSOENH:" TO "_DDNS,1:"")
SET MESS="TRANSMISSION FAILED"_$SELECT(PSOENH:" TO "_DDNS,1:"")
SET STA=3
DO UFILE
DO ALERT
QUIT
+45 IF $GET(HLMID)
IF $PIECE($GET(HLERR),"^")=""
SET MESS="MESSAGE TRANSMITTED"_$SELECT(PSOENH:" TO "_$GET(OPNAM(DDNS))_" ("_DDNS_")",1:"")
SET STA=1
DO UFILE
End DoDot:1
+46 GOTO EXIT
LOGMSG ;build status of message in log file (#52.51)
+1 NEW PSODEV,PSOMES,STR
+2 SET PSODEV=PSOADD
+3 DO LOGBLD
+4 SET $PIECE(^TMP("PSOMID",$JOB,II),"^",4)=PSOMES
+5 ;build message for the storage devices
+6 IF PSOENH
Begin DoDot:1
+7 SET PSODEV=""
FOR
SET PSODEV=$ORDER(ADDCAT("S",PSODEV))
if PSODEV=""
QUIT
IF PSODEV'=PSOADD
Begin DoDot:2
+8 DO LOGBLD
+9 SET STR=$PIECE(^TMP("PSOMID",$JOB,II),"^",4)
SET STR=$SELECT(STR'="":STR_";",1:"")_PSOMES
+10 SET $PIECE(^TMP("PSOMID",$JOB,II),"^",4)=STR
End DoDot:2
End DoDot:1
+11 QUIT
LOGBLD ;audit log file #52.51
+1 NEW DIK,DIC,DA,DD,DO
+2 SET DIC="^PS(52.51,"
SET X=IRXN
SET DIC(0)=""
+3 SET DIC("DR")="2////"_DFN_";3////"_DTME_";4////"_PRSN_";5////"_RPRT_";6////"_STPMTR_";8////"_FP_";9////"_FPN_";15////"_DIV_";13////"_"BUILDING MESSAGE"_$SELECT(PSOENH:" TO SEND TO "_PSODEV,1:"")_";14////1"
+4 DO FILE^DICN
KILL DD,DO,DIC
+5 SET PSOMES=$PIECE(Y,"^")
+6 KILL Y
+7 QUIT
UFILE FOR II=0:0
SET II=$ORDER(^TMP("PSOMID",$JOB,II))
if 'II
QUIT
SET III=$GET(^(II))
Begin DoDot:1
+1 SET PRXX=$PIECE(III,"^",4)
SET PFP=$PIECE(III,"^",2)
SET PFPN=$PIECE(III,"^",3)
+2 FOR XX=1:1
SET PRX=$PIECE(PRXX,";",XX)
if PRX=""
QUIT
Begin DoDot:2
+3 if '$DATA(^PS(52.51,PRX))
QUIT
+4 IF $PIECE($GET(^PS(52.51,PRX,0)),"^",8)=PFP
IF $PIECE($GET(^PS(52.51,PRX,0)),"^",9)=PFPN
Begin DoDot:3
+5 IF PSOENH
IF $GET(^PS(52.51,PRX,1))'[DDNS
QUIT
+6 SET DA=PRX
SET DIE="^PS(52.51,"
SET DR="10////"_HLMID_";13////"_MESS_";14////"_STA_""
DO ^DIE
+7 IF PSOENH
DO ACLOG
End DoDot:3
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
EXIT if $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 KILL ^TMP("PSOMID",$JOB),MESS,PSODTM,STA,HLMID,PRX,PFP,PFPN,CS,CPY,DAW,DIN,DRI,EC,FP,FPN,FS,ING,IRXN,IDGN,II,JJ,ODR,PSI,RS,SCS,SDI,%
+2 KILL DA,DIE,DIV,DR,DTME,HL1,HLERR,HLPDT,XXX,DFN,PAS,STPMTR,X,III,PIEN,PRSN,RPRT,PAS1,PAS2,PAS3,PRXX,XX,J
+3 KILL ^TMP("HLS",$JOB),^TMP("PSO",$JOB),^TMP("PSOADD",$JOB)
+4 QUIT
+5 ;
ERRMSG SET EMSG=""
+1 FOR AA=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
SET EMSG=EMSG_"&&"_HLNODE
+2 SET ^TMP("PSO2",$JOB)=EMSG
+3 QUIT
ACK ;process MSA received from the dispense machine (client)
+1 ;
+2 if '$DATA(HL("APAT"))
SET HL("APAT")="AL"
+3 SET AACK=HL("APAT")
SET DTM=HL("DTM")
SET ETN=HL("ETN")
SET CMID=HL("MID")
+4 SET MTN=HL("MTN")
SET RAN=HL("RAN")
SET SAN=HL("SAN")
SET VER=HL("VER")
+5 SET EID=HL("EID")
SET EIDS=HL("EIDS")
SET FS=HL("FS")
+6 IF $GET(VER)'="2.4"
GOTO EXT
+7 NEW ORC
KILL PSOMSG
FOR I=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
SET PSOMSG(I)=HLNODE
SET J=0
Begin DoDot:1
+8 IF $PIECE(PSOMSG(I),"|")="MSA"
SET MSACDE=$PIECE(PSOMSG(I),"|",2)
SET SMID=$PIECE(PSOMSG(I),"|",3)
if $PIECE(PSOMSG(I),"|",4)]""
SET ERRMSG=$PIECE(PSOMSG(I),"|",4)
+9 IF $PIECE(PSOMSG(I),"|")="ORC"
SET ORC="1^"_+$PIECE(PSOMSG(I),"|",3)
+10 IF $PIECE(PSOMSG(I),"|")="RXD"
SET PSOFNHL7=$PIECE(PSOMSG(I),"|",2)
+11 FOR
SET J=$ORDER(HLNODE(J))
if 'J
QUIT
SET PSOMSG(I,J)=HLNODE(J)
End DoDot:1
+12 ;
+13 IF SMID'=""
IF $DATA(^PSRXR(52.09,"F",SMID))
GOTO ACK^PSORLLLI
+14 SET ^TMP("PSO1",$JOB,CMID)=CMID_"^"_AACK_"^"_DTM_"^"_ETN_"^"_MTN_"^"_RAN_"^"_SAN_"^"_VER_"^"_EID_"^"_EIDS
+15 ;
+16 SET (DIV1,SP1,SP2)=""
FOR
SET DIV1=$ORDER(^PS(52.51,"AM",SMID,DIV1))
if 'DIV1
QUIT
FOR
SET SP1=$ORDER(^PS(52.51,"AM",SMID,DIV1,SP1))
if 'SP1!(SP1=2)
QUIT
SET SP2=$PIECE($GET(^PS(52.51,SP1,0)),"^",6)
+17 IF '$DATA(MSACDE)
GOTO EXT
+18 IF $GET(MSACDE)="AA"
DO ACK1
+19 IF $GET(MSACDE)="AE"!$GET(MSACDE)="AR"
DO ACK2
+20 ;
EXT ;
+1 KILL ^TMP("PSO1",$JOB),AACK,DTM,ETN,CMID,MTN,RAN,SAN,VER,EID,EIDS,FS,MSA,AA,RPT
+2 KILL MSA1,MSACDE,SMID,ERRMSG,DIV1,SP1,SP2,HL,UID,FLL,FLLN,IRX,FLD12,FLD13
+3 KILL DIE,EMSG,HLQUIT,HLNEXT,HLNODE,PSOMSG,ORC,EIN
+4 QUIT
+5 ;
ACK1 ;
+1 SET FLD13=$SELECT($GET(ORC):"MEDICATION DISPENSED",1:"TO BE PROCESSED")
DO FACK1
+2 QUIT
+3 ;
ACK2 SET XQAMSG="Error processing batch "_SMID_". Interface will continue to transmit."
SET FLD13="PROCESS FAILED"
if $GET(ERRMSG)
SET FLD12=ERRMSG
+1 DO FACK2
DO ALERT
+2 QUIT
+3 ;
ALERT ;send alert to key holders
+1 KILL XQA,XQAOPT,XQAROU,XQAID,XQADATA,XQAFLAG
+2 FOR UID=0:0
SET UID=$ORDER(^XUSEC("PSOINTERFACE",UID))
if 'UID
QUIT
SET XQA(UID)=""
+3 DO SETUP^XQALERT
+4 QUIT
UDFILE ;updates from vendor
+1 SET (DIV1,SP1)=""
FOR
SET DIV1=$ORDER(^PS(52.51,"AM",SMID,DIV1))
if 'DIV1
QUIT
FOR
SET SP1=$ORDER(^PS(52.51,"AM",SMID,DIV1,SP1))
if 'SP1
QUIT
SET (EIN,DA)=SP1
Begin DoDot:1
+2 SET DIE="^PS(52.51,"
SET DR="7////"_SAN_";11////"_CMID_";13////"_FLD13_";14////2"
DO ^DIE
End DoDot:1
+3 QUIT
FACK1 ;
+1 NEW RX,RXNA,RXNAQ,RXDIV
+2 if '$GET(ORC)
DO UDFILE
+3 IF $GET(ORC)
Begin DoDot:1
+4 SET RXNAQ=0
SET RXNA=$PIECE(ORC,"^",2)
+5 ; Trying to match via MESSAGE SERVER ID (HL7) - Should always find a match
+6 IF SMID'=""
Begin DoDot:2
+7 SET RXDIV=""
FOR
SET RXDIV=$ORDER(^PS(52.51,"AM",SMID,RXDIV))
if (('RXDIV)!(RXNAQ))
QUIT
Begin DoDot:3
+8 SET RX=""
FOR
SET RX=$ORDER(^PS(52.51,"AM",SMID,RXDIV,RX))
if (('RX)!(RXNAQ))
QUIT
Begin DoDot:4
+9 IF $$GET1^DIQ(52.51,RX,.01,"I")=RXNA
SET (EIN,DA)=RX
SET RXNAQ=1
End DoDot:4
End DoDot:3
End DoDot:2
+10 ; Trying to match with a REGULAR Fill (Non-Partials) - 'Fail Safe' matching logic
+11 IF '$GET(DA)
Begin DoDot:2
+12 SET RX=""
FOR
SET RX=$ORDER(^PS(52.51,"B",RXNA,RX),-1)
if (('RX)!(RXNAQ))
QUIT
Begin DoDot:3
+13 ; Partial Fill
IF $$GET1^DIQ(52.51,RX,8,"I")="P"
QUIT
+14 IF $$GET1^DIQ(52.51,RX,9,"I")=PSOFNHL7
SET (EIN,DA)=RX
SET RXNAQ=1
End DoDot:3
End DoDot:2
+15 ; Trying to match with a PARTIAL Fill (OPAI returns either 0 or 1 for Partial Fill #) - 'Fail Safe' matching logic
+16 IF '$GET(DA)
Begin DoDot:2
+17 SET RX=""
FOR
SET RX=$ORDER(^PS(52.51,"B",RXNA,RX),-1)
if (('RX)!(RXNAQ))
QUIT
Begin DoDot:3
+18 ; Regular Fill
IF $$GET1^DIQ(52.51,RX,8,"I")'="P"
QUIT
+19 SET (EIN,DA)=RX
SET RXNAQ=1
End DoDot:3
End DoDot:2
+20 IF $GET(DA)
Begin DoDot:2
+21 IF $PIECE($GET(^PS(52.51,DA,1)),"^",4)="MEDICATION DISPENSED"
IF $PIECE(^PS(52.51,DA,0),"^",10)=2
SET MDUP=1
DO ^PSOHLDIS
KILL EIN,MDUP
QUIT
+22 SET HLUSER=$PIECE(^PS(52.51,DA,0),"^",4)
SET HLRPT=$PIECE(^(0),"^",5)
+23 SET DIE="^PS(52.51,"
SET DR="7////"_SAN_";11////"_CMID_";13////"_FLD13_";14////2"
DO ^DIE
DO ^PSOHLDIS
KILL EIN,HLUSER,HLRPT
End DoDot:2
End DoDot:1
+24 QUIT
+25 ;
FACK2 ;
+1 DO UDFILE
if '$GET(^PSRX($PIECE(^PS(52.51,EIN,0),"^"),0))
QUIT
+2 SET ACL=0
SET IRX=$PIECE(^PS(52.51,EIN,0),"^")
SET FLL=$PIECE(^(0),"^",8)
SET FLLN=$PIECE(^(0),"^",9)
SET RXN=$PIECE(^PSRX(IRX,0),"^")
+3 FOR I=0:0
SET SUB=$ORDER(^PSRX(IRX,"A",I))
if 'I
QUIT
SET ACL=(ACL+1)
+4 DO NOW^%DTC
SET ACL=ACL+1
SET ^PSRX(IRX,"A",0)="^52.3DA^"_ACL_"^"_ACL
+5 SET ^PSRX(IRX,"A",ACL,0)=%_"^N^^"_$SELECT(FLL="F":FLLN,1:(99-FLLN))_"^External Interface Rx NOT Dispensed."
KILL ACL,I,RXN
+6 QUIT
+7 ;
GETDEV ;get devices associated with dispensing printer
+1 ;Create array OPADD & ADDCAT
+2 ; Output: OPADD(dns)=port
+3 ; ADDCAT(category,dns)=""
+4 ;
+5 NEW DDNS,DPORT,PIO,PN,DN,DEV,DAT,DAT1
+6 KILL OPADD,ADDCAT
+7 SET PN=$GET(^UTILITY($JOB,"PSOPAI"))
SET PIO=$ORDER(^PS(59,PSOSITE,"P","B",+PN,""))
+8 SET DN=$ORDER(^PS(59,PSOSITE,"P",+PIO,"OPAI",0))
+9 IF ('PIO)!(DN="")
Begin DoDot:1
+10 SET DDNS=$$GET1^DIQ(59,PSOSITE_",",2006)
SET DPORT=$$GET1^DIQ(59,PSOSITE_",",2007)
SET OPADD(DDNS)=DPORT
End DoDot:1
QUIT
+11 SET PSOENH=1
SET DEV=0
FOR
SET DEV=$ORDER(^PS(59,PSOSITE,"P",PIO,"OPAI",DEV))
if 'DEV
QUIT
Begin DoDot:1
+12 SET DAT=$GET(^PS(59,PSOSITE,"P",PIO,"OPAI",DEV,0))
IF $PIECE(DAT,"^",2)=""
QUIT
+13 SET DAT1=$$ADDCHK($PIECE(DAT,"^"))
IF DAT1
Begin DoDot:2
+14 SET OPADD($PIECE(DAT1,"^",3))=$PIECE(DAT1,"^",4)
SET ADDCAT($PIECE(DAT,"^",2),$PIECE(DAT1,"^",3))=""
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
CHKCAT ;checks the ADD category to determine if and where the prescription should be routed.
+1 NEW PDAT,DRG,DRG0,DDEV,RTE,CSB,MTH,DEV53
+2 SET PSOADD=""
+3 IF $GET(PSONEADS)
SET DRG=PSOLDRUG
SET RTE=$EXTRACT($GET(PSOHLSV("ROUTING")))
+4 IF '$GET(PSONEADS)
SET PDAT=$GET(^PSRX(IRXN,0))
SET DRG=$PIECE(PDAT,"^",6)
SET RTE=$$RTE()
+5 SET DRG0=$GET(^PSDRUG(+DRG,0))
SET DDEV=$GET(^PSDRUG(DRG,"OPAI",PSOSITE,0))
+6 IF DDEV'=""
SET DEV53=$$ADDCHK($SELECT(RTE="W":$PIECE(DDEV,"^",2),RTE="M":$PIECE(DDEV,"^",3),1:""))
IF DEV53
Begin DoDot:1
+7 IF $DATA(OPADD($PIECE(DEV53,"^",3)))
SET PSOADD=$PIECE(DEV53,"^",3)
QUIT
+8 SET OPADD($PIECE(DEV53,"^",3))=$PIECE(DEV53,"^",4)
SET PSOADD=$PIECE(DEV53,"^",3)
End DoDot:1
QUIT
+9 IF $DATA(ADDCAT("A"))
SET PSOADD=$ORDER(ADDCAT("A",""))
QUIT
+10 SET CSB=+$PIECE(DRG0,"^",3)
SET CSB=$SELECT((CSB>0)&(CSB<6):"CS",1:"NCS")
+11 IF $DATA(ADDCAT(CSB))
SET PSOADD=$ORDER(ADDCAT(CSB,""))
QUIT
+12 IF $DATA(ADDCAT(RTE_CSB))
SET PSOADD=$ORDER(ADDCAT(RTE_CSB,""))
QUIT
+13 SET MTH=$SELECT(RTE="W":"WIND",RTE="M":"MAIL",1:"")
IF MTH'=""
IF $DATA(ADDCAT(MTH))
SET PSOADD=$ORDER(ADDCAT(MTH,""))
QUIT
+14 IF $DATA(ADDCAT("S"))
SET PSOADD=$ORDER(ADDCAT("S",""))
QUIT
+15 QUIT
+16 ;
STRAGE ;set HL7 entries in ^TMP global to be sent to the storage device.
+1 NEW DNS,CNT,CNT1,STR
+2 SET DNS=$ORDER(ADDCAT("S",""))
IF DNS=""
QUIT
+3 IF DNS=PSOADD
QUIT
+4 IF '$DATA(^TMP("PSOADD",$JOB,DNS))
Begin DoDot:1
+5 MERGE ^TMP("PSOADD",$JOB,DNS)=^TMP("PSO",$JOB)
SET $PIECE(OPADD(DNS),"^",2)=PSI
End DoDot:1
QUIT
+6 SET CNT=0
FOR
SET CNT=$ORDER(^TMP("PSO",$JOB,CNT))
if 'CNT
QUIT
Begin DoDot:1
+7 SET STR=$GET(^TMP("PSO",$JOB,CNT))
+8 IF "^PID^PV1^PV2^IAM^"[("^"_$EXTRACT(STR,1,3)_"^")
QUIT
+9 SET CNT1=+$PIECE(OPADD(DNS),"^",2)
+10 MERGE ^TMP("PSOADD",$JOB,DNS,CNT1)=^TMP("PSO",$JOB,CNT)
+11 SET CNT1=CNT1+1
SET $PIECE(OPADD(DNS),"^",2)=CNT1
End DoDot:1
+12 QUIT
MORSTG ;if more than one storage device is defined, add the others to the ^TMP global
+1 NEW RDNS,DNS
+2 SET DNS=$ORDER(ADDCAT("S",""))
IF DNS=""
QUIT
+3 SET RDNS=DNS
FOR
SET RDNS=$ORDER(ADDCAT("S",RDNS))
if RDNS=""
QUIT
Begin DoDot:1
+4 MERGE ^TMP("PSOADD",$JOB,RDNS)=^TMP("PSOADD",$JOB,DNS)
End DoDot:1
+5 QUIT
+6 ;
ADDCHK(DEV) ;check ADD in file #52.53 and return status and the zero node
+1 ; 1 - valid or 0 - invalid
+2 IF $GET(DEV)=""
QUIT 0
+3 NEW DEVD
+4 SET DEVD=$GET(^PS(52.53,DEV,0))
+5 IF ($PIECE(DEVD,"^")="")!($PIECE(DEVD,"^",2)="")!($PIECE(DEVD,"^",3)="")
QUIT 0_"^"_DEVD
+6 IF $PIECE(DEVD,"^",4)
IF $PIECE(DEVD,"^",4)'>DT
QUIT 0_"^"_DEVD
+7 QUIT 1_"^"_DEVD
+8 ;
ALLADD ;get all active ADDs in #52.53
+1 ; OPNAM(dns)=dns name
+2 NEW X,XD
+3 KILL OPNAM
+4 SET X=0
FOR
SET X=$ORDER(^PS(52.53,X))
if 'X
QUIT
Begin DoDot:1
+5 SET XD=$GET(^PS(52.53,X,0))
+6 if ($PIECE(XD,"^")="")!($PIECE(XD,"^",2)="")!($PIECE(XD,"^",3)="")
QUIT
+7 IF $PIECE(XD,"^",4)
IF $PIECE(XD,"^",4)'>DT
QUIT
+8 IF $GET(PSONECT)
SET PSONECTC=PSONECTC+1
+9 SET OPNAM($PIECE(XD,"^",2))=$PIECE(XD,"^")
End DoDot:1
+10 QUIT
+11 ;
ACLOG ;activity log (HL7 message transmitted to the interface)
+1 NEW DTTM,HCOM,HCNT,HJJ,IEN52
+2 SET IEN52=$PIECE($GET(^PS(52.51,PRX,0)),"^")
+3 DO NOW^%DTC
SET DTTM=%
SET HCOM=MESS
+4 SET HCNT=0
FOR HJJ=0:0
SET HJJ=$ORDER(^PSRX(IEN52,"A",HJJ))
if 'HJJ
QUIT
SET HCNT=HJJ
+5 SET HCNT=HCNT+1
SET ^PSRX(IEN52,"A",0)="^52.3DA^"_HCNT_"^"_HCNT
SET ^PSRX(IEN52,"A",HCNT,0)=DTTM_"^X^"_$SELECT($GET(PDUZ):PDUZ,1:.5)_"^"_"^"_$SELECT($GET(HLMID):"HL7 ID - "_HLMID,1:"")_" "_HCOM
+6 QUIT
RTE() ;get RX route
+1 NEW MW
+2 ;original
IF $GET(FP)="F"&('$GET(FPN))
SET MW=$PIECE($GET(^PSRX(IRXN,0)),"^",11)
+3 ;refill
IF $GET(FP)="F"&($GET(FPN))
SET MW=$PIECE($GET(^PSRX(IRXN,1,FPN,0)),"^",2)
+4 ;partial
IF $GET(FP)="P"&($GET(FPN))
SET MW=$PIECE($GET(^PSRX(IRXN,"P",FPN,0)),"^",2)
+5 QUIT $GET(MW)
