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