PSOHLDS ;BIR/PWC-HL7 V.2.4 AUTOMATED DISPENSE INTERFACE ;03/01/96 09:45
;;7.0;OUTPATIENT PHARMACY;**156**;DEC 1997
;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
;
INIT ;initialize variables and build outgoing message
N DFLAG,HLRESLT,HLP,PSLINK,PSOHLSER,PSOHLCL,PSOHLINX
S PSOHLINX=$$GETAPP^HLCS2("PSO EXT SERVER") Q:$P($G(PSOHLINX),"^",2)="i"
K ^TMP("PSO",$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
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
..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)
.K 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"_";14////1"
.D FILE^DICN K DD,DO,Y,DIC D START^PSOHLDS1
K ^TMP("HLS",$J)
M ^TMP("HLS",$J)=^TMP("PSO",$J) K ^TMP("PSO",$J)
S PSLINK=$O(^UTILITY($J,"PSOHL",0))
S DDNS=$$GET1^DIQ(59,PSOSITE_",",2006),DPORT=$$GET1^DIQ(59,PSOSITE_",",2007)
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" D ALERT G EXIT
I $G(HLMID),$P($G(HLERR),"^")'="" S XQAMSG="Error transmitting batch "_HLMID_" to the external interface",MESS="TRANSMISSION FAILED",STA=3 D UFILE,ALERT G EXIT
I $G(HLMID),$P($G(HLERR),"^")="" S MESS="MESSAGE TRANSMITTED",STA=1 D UFILE G EXIT
UFILE F II=0:0 S II=$O(^TMP("PSOMID",$J,II)) Q:'II S III=$G(^(II)) D
.S PRX=$P(III,"^"),PFP=$P(III,"^",2),PFPN=$P(III,"^",3)
.Q:'$D(^PS(52.51,"B",PRX))
.S JJ="" F S JJ=$O(^PS(52.51,"B",PRX,JJ)) Q:JJ="" D
..I $P(^PS(52.51,JJ,0),"^")=PRX,$P(^(0),"^",8)=PFP,$P(^(0),"^",9)=PFPN S DA=JJ,DIE="^PS(52.51,",DR="10////"_HLMID_";13////"_MESS_";14////"_STA_"" D ^DIE
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
K ^TMP("HLS",$J),^TMP("PSO",$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)
.F S J=$O(HLNODE(J)) Q:'J S PSOMSG(I,J)=HLNODE(J)
;
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 ;
D:'$G(ORC) UDFILE
I $G(ORC) D
.S RXN=$P(ORC,"^",2),RX=0 F S RX=$O(^PS(52.51,"B",RXN,RX)) Q:'RX S (EIN,DA)=RX
.I $G(DA) D
..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
PSOHLDS ;BIR/PWC-HL7 V.2.4 AUTOMATED DISPENSE INTERFACE ;03/01/96 09:45
+1 ;;7.0;OUTPATIENT PHARMACY;**156**;DEC 1997
+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 ;
INIT ;initialize variables and build outgoing message
+1 NEW DFLAG,HLRESLT,HLP,PSLINK,PSOHLSER,PSOHLCL,PSOHLINX
+2 SET PSOHLINX=$$GETAPP^HLCS2("PSO EXT SERVER")
IF $PIECE($GET(PSOHLINX),"^",2)="i"
QUIT
+3 KILL ^TMP("PSO",$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 FOR II=0:0
SET II=$ORDER(^UTILITY($JOB,"PSOHL",II))
IF 'II
QUIT
SET ODR=^UTILITY($JOB,"PSOHL",II)
Begin DoDot:1
+11 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)
+12 SET ^TMP("PSOMID",$JOB,II)=IRXN_"^"_FP_"^"_FPN
IF DIN=1
Begin DoDot:2
+13 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
+14 SET SDI=$PIECE(ODR,"^",7)
IF SDI=1
SET DRI=^UTILITY($JOB,"PSOHL",II,"DRI")
+15 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)
+16 IF $GET(STPMTR)>1&($PIECE($GET(^PSRX(IRXN,"STA")),"^")=5)
Begin DoDot:2
+17 NEW PSOHLSPZ,PSOHLNDA
SET PSOHLSPZ=$ORDER(^PS(52.5,"B",IRXN,0))
SET PSOHLNDA=""
+18 IF PSOHLSPZ
SET PSOHLNDA=$GET(^PS(52.5,PSOHLSPZ,0))
+19 IF $GET(RXPR(IRXN))
IF +$GET(RXPR(IRXN))'=$PIECE(PSOHLNDA,"^",5)
QUIT
+20 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
+21 DO SUS^PSOLBL4(IRXN,FP,FPN,RPRT)
End DoDot:2
+22 KILL DIK,DIC,DA,DD,DO
SET DIC="^PS(52.51,"
SET X=IRXN
SET DIC(0)=""
+23 SET DIC("DR")="2////"_DFN_";3////"_DTME_";4////"_PRSN_";5////"_RPRT_";6////"_STPMTR_";8////"_FP_";9////"_FPN_";15////"_DIV_";13////"_"BUILDING MESSAGE"_";14////1"
+24 DO FILE^DICN
KILL DD,DO,Y,DIC
DO START^PSOHLDS1
End DoDot:1
+25 KILL ^TMP("HLS",$JOB)
+26 MERGE ^TMP("HLS",$JOB)=^TMP("PSO",$JOB)
KILL ^TMP("PSO",$JOB)
+27 SET PSLINK=$ORDER(^UTILITY($JOB,"PSOHL",0))
+28 SET DDNS=$$GET1^DIQ(59,PSOSITE_",",2006)
SET DPORT=$$GET1^DIQ(59,PSOSITE_",",2007)
+29 SET HLP("CONTPTR")=""
SET HLP("SUBSCRIBER")="^^^^~"_DDNS_":"_DPORT_"~DNS"
+30 DO GENERATE^HLMA(PIEN,"GM",1,.HLRESLT,"",.HLP)
+31 KILL HLL
SET HLMID=$PIECE($GET(HLRESLT),"^")
SET HLERR=$PIECE($GET(HLRESLT),"^",2)
+32 IF '$GET(HLMID)
SET XQAMSG="Error transmitting "_$PIECE(^DPT(DFN,0),"^")_" order to external interface"
DO ALERT
GOTO EXIT
+33 IF $GET(HLMID)
IF $PIECE($GET(HLERR),"^")'=""
SET XQAMSG="Error transmitting batch "_HLMID_" to the external interface"
SET MESS="TRANSMISSION FAILED"
SET STA=3
DO UFILE
DO ALERT
GOTO EXIT
+34 IF $GET(HLMID)
IF $PIECE($GET(HLERR),"^")=""
SET MESS="MESSAGE TRANSMITTED"
SET STA=1
DO UFILE
GOTO EXIT
UFILE FOR II=0:0
SET II=$ORDER(^TMP("PSOMID",$JOB,II))
IF 'II
QUIT
SET III=$GET(^(II))
Begin DoDot:1
+1 SET PRX=$PIECE(III,"^")
SET PFP=$PIECE(III,"^",2)
SET PFPN=$PIECE(III,"^",3)
+2 IF '$DATA(^PS(52.51,"B",PRX))
QUIT
+3 SET JJ=""
FOR
SET JJ=$ORDER(^PS(52.51,"B",PRX,JJ))
IF JJ=""
QUIT
Begin DoDot:2
+4 IF $PIECE(^PS(52.51,JJ,0),"^")=PRX
IF $PIECE(^(0),"^",8)=PFP
IF $PIECE(^(0),"^",9)=PFPN
SET DA=JJ
SET DIE="^PS(52.51,"
SET DR="10////"_HLMID_";13////"_MESS_";14////"_STA_""
DO ^DIE
End DoDot:2
End DoDot:1
+5 QUIT
+6 ;
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
+3 KILL ^TMP("HLS",$JOB),^TMP("PSO",$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 FOR
SET J=$ORDER(HLNODE(J))
IF 'J
QUIT
SET PSOMSG(I,J)=HLNODE(J)
End DoDot:1
+11 ;
+12 SET ^TMP("PSO1",$JOB,CMID)=CMID_"^"_AACK_"^"_DTM_"^"_ETN_"^"_MTN_"^"_RAN_"^"_SAN_"^"_VER_"^"_EID_"^"_EIDS
+13 ;
+14 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)
+15 IF '$DATA(MSACDE)
GOTO EXT
+16 IF $GET(MSACDE)="AA"
DO ACK1
+17 IF $GET(MSACDE)="AE"!$GET(MSACDE)="AR"
DO ACK2
+18 ;
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 IF '$GET(ORC)
DO UDFILE
+2 IF $GET(ORC)
Begin DoDot:1
+3 SET RXN=$PIECE(ORC,"^",2)
SET RX=0
FOR
SET RX=$ORDER(^PS(52.51,"B",RXN,RX))
IF 'RX
QUIT
SET (EIN,DA)=RX
+4 IF $GET(DA)
Begin DoDot:2
+5 SET HLUSER=$PIECE(^PS(52.51,DA,0),"^",4)
SET HLRPT=$PIECE(^(0),"^",5)
+6 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
+7 QUIT
+8 ;
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
