PSOLBL4 ;BIR/RTR-Set up routine for HL7 interface ; 10/9/08 11:37am
;;7.0;OUTPATIENT PHARMACY;**26,70,156,244,233,246,319**;DEC 1997;Build 1
;External reference to ^PSDRUG supported by DBIA 221
;
;*244 - ignore RX's with a status > 11
;*246 - send marked drugs & print label (option 4) now working
;
N DIC,AP,X,Y,DPRT,QPRT
I $G(ZTIO)]"" D
.Q:'$O(^PS(59,PSOSITE,"P",0))
.S DIC=3.5,DIC(0)="",X=ZTIO D ^DIC K DIC,X Q:Y=-1
.S DPRT=+Y
.F AP=0:0 S AP=$O(^PS(59,PSOSITE,"P",AP)) Q:'AP I +$P(^PS(59,PSOSITE,"P",AP,0),"^")=DPRT S QPRT=1
.I '$G(QPRT) S $P(PSOPAR,"^",30)=0
Q:'$P($G(PSOPAR),"^",30) ;HL7 interface turned off
Q:$G(PSOEXREP)
HL N PSODTM,HHHH,PSOQUE,HLFLAG,HLFOUR,HLINGF,HLINRX,HLINRX0,II,HLNEXT,HLRR,HLRX,HLRXY,LL,PPLHL,PSHALP,HDFN,HLDFN,HNEWDFN,HLDAI,HLOSITE,HLJUST,HLRXYZ,PSOLLN,PSOLLL,PSFLG,HDFN1,NOTMD
S HLOSITE=$P($G(PSOPAR),"^",30)
K ^UTILITY($J,"PSOHL"),^UTILITY($J,"PSOHLL"),HLRXY
S PPLHL=PPL
S HLFLAG=0 F II=1:1 S HLRX=$P(PPLHL,",",II) D Q:$G(HLFLAG)
.S HLNEXT=$P(PPLHL,",",(II+1)) I HLNEXT=""!(HLNEXT=",") S HLFLAG=1
.Q:'$G(HLRX)
.Q:'$D(^PSRX(HLRX,0))
.Q:$P($G(^PSRX(HLRX,"STA")),"^")=4
.Q:$G(RXRP(HLRX,"RP"))
.I $P($G(^PSRX(HLRX,"STA")),"^")>11!('$P(^PSRX(HLRX,0),"^",2)) Q
.I $G(PSODBQ) S HLRR=$O(^PS(52.5,"B",HLRX,0)) Q:'HLRR I $G(^PS(52.5,+HLRR,"P"))=1 Q
.; marked drug options 3 & 4
.I (HLOSITE=3)!(HLOSITE=4) S NOTMD=0 D Q:NOTMD ;quit, not marked
..S HLJUST=+$P($G(^PSRX(HLRX,0)),"^",6)
..S:'$P($G(^PSDRUG(HLJUST,6)),"^") NOTMD=1
.S HLRXY(II,HLRX)="" ;Valid Rx for HL7
.S:HLOSITE=3 HLRXYZ(HLRX)=""
;
I $G(HLOSITE)=3,$D(HLRXY) D ;rebuild PPL print string
.K PPL F II=1:1 S HLRX=$P(PPLHL,",",II) Q:'HLRX D
..Q:$D(HLRXYZ(HLRX))
..S PPL=$G(PPL)_HLRX_","
;
SOMDQ S (II,PSOQUE)=0 F S II=$O(HLRXY(II)) Q:'II S ^UTILITY($J,"PSOHLL",II)=$O(HLRXY(II,0)),PSOQUE=II
I PSOQUE=0 G ENDHL ;Nothing set, bypass Call to Queue
F II=0:0 S II=$O(^UTILITY($J,"PSOHLL",II)) Q:'II S HLINRX=^(II),HLINRX0=$G(^PSRX(HLINRX,0)) D
.S ^UTILITY($J,"PSOHLL",II)=HLINRX_"^"_+$P(HLINRX0,"^",6)_"^"_$S($G(RXPR(HLINRX)):"P",1:"F")
.I '$G(RXPR(HLINRX)) S HLFOUR=0 F HHHH=0:0 S HHHH=$O(^PSRX(HLINRX,1,HHHH)) Q:'HHHH I +^(HHHH,0) S HLFOUR=HHHH
.I '$G(RXPR(HLINRX)),$G(RXFL(HLINRX))'="" S HLFOUR=$S($G(RXFL(HLINRX))=0:0,$D(^PSRX(HLINRX,1,+$G(RXFL(HLINRX)),0)):+$G(RXFL(HLINRX)),1:$G(HLFOUR))
.S ^UTILITY($J,"PSOHLL",II)=^UTILITY($J,"PSOHLL",II)_"^"_$S($G(RXPR(HLINRX)):RXPR(HLINRX),1:HLFOUR)_"^"_$S($P($G(^PSRX(HLINRX,3)),"^",6)&('$G(RXPR(HLINRX)))&('$G(RXFL(HLINRX))):1,1:0) D ACLOG
.S HLINGF=0 I $P(^UTILITY($J,"PSOHLL",II),"^",5),$O(^PSRX(HLINRX,"DAI",0)) S HLINGF=1 D
..F LL=0:0 S LL=$O(^PSRX(HLINRX,"DAI",LL)) Q:'LL S ^UTILITY($J,"PSOHLL",II,HLINGF)=$G(^PSRX(HLINRX,"DAI",LL,0)),HLINGF=HLINGF+1
.S $P(^UTILITY($J,"PSOHLL",II),"^",6)=$S($G(HLINGF):1,1:0)
.I $D(^PSRX(HLINRX,"DRI")),'$G(RXPR(HLINRX)),'$G(RXFL(HLINRX)) S ^UTILITY($J,"PSOHLL",II,"DRI")=^PSRX(HLINRX,"DRI"),$P(^UTILITY($J,"PSOHLL",II),"^",7)=1
.E S $P(^UTILITY($J,"PSOHLL",II),"^",7)=0
.S $P(^UTILITY($J,"PSOHLL",II),"^",8)=0 D RPT Q:'$G(^PSRX(HLINRX,"IB"))
.I $P(^PSRX(HLINRX,"STA"),"^")>0,$P(^("STA"),"^")'=2,'$G(PSODBQ) Q
.S $P(^UTILITY($J,"PSOHLL",II),"^",8)=1
;
AAA D STRT^PSOHLSG5
S (HDFN,HDFN1)=$O(^UTILITY($J,"PSOHLL",0)),HDFN=$P(^PSRX($P(^(HDFN),"^"),0),"^",2),PSOLLL=$P(^UTILITY($J,"PSOHLL",HDFN1),"^",12)
F HLDFN=0:0 S HLDFN=$O(^UTILITY($J,"PSOHLL",HLDFN)) Q:'HLDFN D S ^UTILITY($J,"PSOHL",HLDFN)=^UTILITY($J,"PSOHLL",HLDFN) D OTHER
.S PSFLG=0,PSOLLN=$P(^UTILITY($J,"PSOHLL",HLDFN),"^",12),HNEWDFN=$P(^PSRX($P(^UTILITY($J,"PSOHLL",HLDFN),"^"),0),"^",2) D
..I HDFN'=HNEWDFN S HDFN=HNEWDFN,PSFLG=1
..I PSOLLL'=PSOLLN S PSOLLL=PSOLLN,PSFLG=1
..I PSFLG=1 D SETZ
I '$D(^UTILITY($J,"PSOHL")) G ENDHL
CALL D SETZ
ENDHL K ^UTILITY($J,"PSOHL"),^UTILITY($J,"PSOHLL"),HLRXY
Q
OTHER I $G(^UTILITY($J,"PSOHLL",HLDFN,"DRI"))'="" S ^UTILITY($J,"PSOHL",HLDFN,"DRI")=^UTILITY($J,"PSOHLL",HLDFN,"DRI")
F HLDAI=0:0 S HLDAI=$O(^UTILITY($J,"PSOHLL",HLDFN,HLDAI)) Q:'HLDAI S ^UTILITY($J,"PSOHL",HLDFN,HLDAI)=^UTILITY($J,"PSOHLL",HLDFN,HLDAI)
Q
ACLOG ;Activity log (sending to Hl7 interface)
N DTTM,HCOM,HCNT,HJJ
D NOW^%DTC S DTTM=%,HCOM="Prescription"_$S($G(RXPR(HLINRX)):" (Partial)",1:"")_$S($G(PSOSUREP)!($G(RXRP(HLINRX))):" (Reprint)",1:"")_" sent to external interface."
S HCNT=0 F HJJ=0:0 S HJJ=$O(^PSRX(HLINRX,"A",HJJ)) Q:'HJJ S HCNT=HJJ
S HCNT=HCNT+1,^PSRX(HLINRX,"A",0)="^52.3DA^"_HCNT_"^"_HCNT S ^PSRX(HLINRX,"A",HCNT,0)=DTTM_"^X^"_$G(PDUZ)_"^"_$S($G(RXPR(HLINRX)):6,$G(HLFOUR)<6:$G(HLFOUR),1:(HLFOUR+1))_"^"_HCOM
Q
SUS(HSREX,HSFL,HSFILL,HSRP) ;
N DA,DIK,DTTM,HSCOM,HSCNT,HSJJ,HSLDUZ,PSHLCPRS
I $P($G(^PSRX(HSREX,"STA")),"^")=5 S $P(^PSRX(HSREX,"STA"),"^")=0 S PSHLCPRS="Removed from Suspense, External Interface." D EN^PSOHLSN1(HSREX,"SC","ZU",PSHLCPRS)
S DA=$O(^PS(52.5,"B",HSREX,0)) I DA K DIK S DIK="^PS(52.5," D ^DIK
I $G(HSFL)="P" S HSLDUZ=+$P($G(^PSRX(HSREX,"P",HSFILL,0)),"^",7)
E S HSLDUZ=$S('HSFILL:+$P($G(^PSRX(HSREX,0)),"^",16),1:+$P($G(^PSRX(HSREX,1,HSFILL,0)),"^",7))
D NOW^%DTC S DTTM=%,HSCOM="Removed from Suspense"_$S($G(HSFL)="P":" (Partial)",1:"")_$S($G(HSRP):" (Reprint)",1:"")_" (External Interface)"
S HSCNT=0 F HSJJ=0:0 S HSJJ=$O(^PSRX(HSREX,"A",HSJJ)) Q:'HSJJ S HSCNT=HSJJ
S HSCNT=HSCNT+1,^PSRX(HSREX,"A",0)="^52.3DA^"_HSCNT_"^"_HSCNT S ^PSRX(HSREX,"A",HSCNT,0)=DTTM_"^X^"_$G(HSLDUZ)_"^"_$S($G(HSFL)="P":6,$G(HSFILL)<6:$G(HSFILL),1:(HSFILL+1))_"^"_$G(HSCOM)
Q
LAB(HLREX,HLFL,HLFILL,HLREPT) ;
N HLDUZ,NOW,DA,HCT,HFF
D NOW^%DTC S NOW=% S HCT=0 F HFF=0:0 S HFF=$O(^PSRX(HLREX,"L",HFF)) Q:'HFF S HCT=HFF
I HLFL="F" S HLDUZ=$S('HLFILL:+$P($G(^PSRX(HLREX,0)),"^",16),1:+$P($G(^PSRX(HLREX,1,HLFILL,0)),"^",7))
I HLFL="P" S HLDUZ=+$P($G(^PSRX(HLREX,"P",HLFILL,0)),"^",7)
S HCT=HCT+1,^PSRX(HLREX,"L",0)="^52.032DA^"_HCT_"^"_HCT
S ^PSRX(HLREX,"L",HCT,0)=NOW_"^"_$S($G(HLFL)="F":HLFILL,1:(99-HLFILL))_"^"_"From Rx number "_$P(^PSRX(HLREX,0),"^")_$S($G(HLFL)="P":" (Partial)",1:"")_$S($G(HLREPT):" (Reprint)",1:"")_" (External Interface)"_"^"_$G(HLDUZ)
N PSOBADR,PSOTEMP
S PSOBADR=$$CHKRX^PSOBAI(HLREX)
I $G(PSOBADR) S PSOTEMP=$P(PSOBADR,"^",2),PSOBADR=$P(PSOBADR,"^")
I $G(PSOBADR),'$G(PSOTEMP) D
.S HCT=HCT+1,^PSRX(HLREX,"L",0)="^52.032DA^"_HCT_"^"_HCT
.S ^PSRX(HLREX,"L",HCT,0)=NOW_"^"_$S($G(HLFL)="F":HLFILL,1:(99-HLFILL))_"^"_"ROUTING="_$G(MW)_" (BAD ADDRESS)"_"^"_$G(HLDUZ)
Q
RPT ;
S $P(^UTILITY($J,"PSOHLL",II),"^",9)=$S($G(PSOSUREP)!($G(RXRP(HLINRX))):1,1:0)
S $P(^UTILITY($J,"PSOHLL",II),"^",10)=+$G(PDUZ)
Q
SETZ ;
D NOW^%DTC S PSODTM=%
S ZTRTN=$S($$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4:"INIT^PSOHLDS",1:"INIT^PSOHLSG")
S ZTIO="",ZTDTH=$H,ZTSAVE("^UTILITY($J,""PSOHL"",")="",ZTSAVE("PSOPAR")="",ZTSAVE("PSOSITE")="",ZTSAVE("PSODTM")="",ZTSAVE("PSOLAP")=""
S ZTSAVE("RXRP(")="",ZTSAVE("RXPR(")="",ZTSAVE("RXFL(")="",ZTSAVE("RXRS(")=""
S ZTDESC=$S($$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4:"Outpatient Automation External Interface",1:"GENERIC INTERFACE LABEL INFORMATION")
D ^%ZTLOAD
K ^UTILITY($J,"PSOHL")
Q
PSOLBL4 ;BIR/RTR-Set up routine for HL7 interface ; 10/9/08 11:37am
+1 ;;7.0;OUTPATIENT PHARMACY;**26,70,156,244,233,246,319**;DEC 1997;Build 1
+2 ;External reference to ^PSDRUG supported by DBIA 221
+3 ;
+4 ;*244 - ignore RX's with a status > 11
+5 ;*246 - send marked drugs & print label (option 4) now working
+6 ;
+7 NEW DIC,AP,X,Y,DPRT,QPRT
+8 IF $GET(ZTIO)]""
Begin DoDot:1
+9 IF '$ORDER(^PS(59,PSOSITE,"P",0))
QUIT
+10 SET DIC=3.5
SET DIC(0)=""
SET X=ZTIO
DO ^DIC
KILL DIC,X
IF Y=-1
QUIT
+11 SET DPRT=+Y
+12 FOR AP=0:0
SET AP=$ORDER(^PS(59,PSOSITE,"P",AP))
IF 'AP
QUIT
IF +$PIECE(^PS(59,PSOSITE,"P",AP,0),"^")=DPRT
SET QPRT=1
+13 IF '$GET(QPRT)
SET $PIECE(PSOPAR,"^",30)=0
End DoDot:1
+14 ;HL7 interface turned off
IF '$PIECE($GET(PSOPAR),"^",30)
QUIT
+15 IF $GET(PSOEXREP)
QUIT
HL NEW PSODTM,HHHH,PSOQUE,HLFLAG,HLFOUR,HLINGF,HLINRX,HLINRX0,II,HLNEXT,HLRR,HLRX,HLRXY,LL,PPLHL,PSHALP,HDFN,HLDFN,HNEWDFN,HLDAI,HLOSITE,HLJUST,HLRXYZ,PSOLLN,PSOLLL,PSFLG,HDFN1,NOTMD
+1 SET HLOSITE=$PIECE($GET(PSOPAR),"^",30)
+2 KILL ^UTILITY($JOB,"PSOHL"),^UTILITY($JOB,"PSOHLL"),HLRXY
+3 SET PPLHL=PPL
+4 SET HLFLAG=0
FOR II=1:1
SET HLRX=$PIECE(PPLHL,",",II)
Begin DoDot:1
+5 SET HLNEXT=$PIECE(PPLHL,",",(II+1))
IF HLNEXT=""!(HLNEXT=",")
SET HLFLAG=1
+6 IF '$GET(HLRX)
QUIT
+7 IF '$DATA(^PSRX(HLRX,0))
QUIT
+8 IF $PIECE($GET(^PSRX(HLRX,"STA")),"^")=4
QUIT
+9 IF $GET(RXRP(HLRX,"RP"))
QUIT
+10 IF $PIECE($GET(^PSRX(HLRX,"STA")),"^")>11!('$PIECE(^PSRX(HLRX,0),"^",2))
QUIT
+11 IF $GET(PSODBQ)
SET HLRR=$ORDER(^PS(52.5,"B",HLRX,0))
IF 'HLRR
QUIT
IF $GET(^PS(52.5,+HLRR,"P"))=1
QUIT
+12 ; marked drug options 3 & 4
+13 ;quit, not marked
IF (HLOSITE=3)!(HLOSITE=4)
SET NOTMD=0
Begin DoDot:2
+14 SET HLJUST=+$PIECE($GET(^PSRX(HLRX,0)),"^",6)
+15 IF '$PIECE($GET(^PSDRUG(HLJUST,6)),"^")
SET NOTMD=1
End DoDot:2
IF NOTMD
QUIT
+16 ;Valid Rx for HL7
SET HLRXY(II,HLRX)=""
+17 IF HLOSITE=3
SET HLRXYZ(HLRX)=""
End DoDot:1
IF $GET(HLFLAG)
QUIT
+18 ;
+19 ;rebuild PPL print string
IF $GET(HLOSITE)=3
IF $DATA(HLRXY)
Begin DoDot:1
+20 KILL PPL
FOR II=1:1
SET HLRX=$PIECE(PPLHL,",",II)
IF 'HLRX
QUIT
Begin DoDot:2
+21 IF $DATA(HLRXYZ(HLRX))
QUIT
+22 SET PPL=$GET(PPL)_HLRX_","
End DoDot:2
End DoDot:1
+23 ;
SOMDQ SET (II,PSOQUE)=0
FOR
SET II=$ORDER(HLRXY(II))
IF 'II
QUIT
SET ^UTILITY($JOB,"PSOHLL",II)=$ORDER(HLRXY(II,0))
SET PSOQUE=II
+1 ;Nothing set, bypass Call to Queue
IF PSOQUE=0
GOTO ENDHL
+2 FOR II=0:0
SET II=$ORDER(^UTILITY($JOB,"PSOHLL",II))
IF 'II
QUIT
SET HLINRX=^(II)
SET HLINRX0=$GET(^PSRX(HLINRX,0))
Begin DoDot:1
+3 SET ^UTILITY($JOB,"PSOHLL",II)=HLINRX_"^"_+$PIECE(HLINRX0,"^",6)_"^"_$SELECT($GET(RXPR(HLINRX)):"P",1:"F")
+4 IF '$GET(RXPR(HLINRX))
SET HLFOUR=0
FOR HHHH=0:0
SET HHHH=$ORDER(^PSRX(HLINRX,1,HHHH))
IF 'HHHH
QUIT
IF +^(HHHH,0)
SET HLFOUR=HHHH
+5 IF '$GET(RXPR(HLINRX))
IF $GET(RXFL(HLINRX))'=""
SET HLFOUR=$SELECT($GET(RXFL(HLINRX))=0:0,$DATA(^PSRX(HLINRX,1,+$GET(RXFL(HLINRX)),0)):+$GET(RXFL(HLINRX)),1:$GET(HLFOUR))
+6 SET ^UTILITY($JOB,"PSOHLL",II)=^UTILITY($JOB,"PSOHLL",II)_"^"_$SELECT($GET(RXPR(HLINRX)):RXPR(HLINRX),1:HLFOUR)_"^"_$SELECT($PIECE($GET(^PSRX(HLINRX,3)),"^",6)&('$GET(RXPR(HLINRX)))&('$GET(RXFL(HLINRX))):1,1:0)
DO ACLOG
+7 SET HLINGF=0
IF $PIECE(^UTILITY($JOB,"PSOHLL",II),"^",5)
IF $ORDER(^PSRX(HLINRX,"DAI",0))
SET HLINGF=1
Begin DoDot:2
+8 FOR LL=0:0
SET LL=$ORDER(^PSRX(HLINRX,"DAI",LL))
IF 'LL
QUIT
SET ^UTILITY($JOB,"PSOHLL",II,HLINGF)=$GET(^PSRX(HLINRX,"DAI",LL,0))
SET HLINGF=HLINGF+1
End DoDot:2
+9 SET $PIECE(^UTILITY($JOB,"PSOHLL",II),"^",6)=$SELECT($GET(HLINGF):1,1:0)
+10 IF $DATA(^PSRX(HLINRX,"DRI"))
IF '$GET(RXPR(HLINRX))
IF '$GET(RXFL(HLINRX))
SET ^UTILITY($JOB,"PSOHLL",II,"DRI")=^PSRX(HLINRX,"DRI")
SET $PIECE(^UTILITY($JOB,"PSOHLL",II),"^",7)=1
+11 IF '$TEST
SET $PIECE(^UTILITY($JOB,"PSOHLL",II),"^",7)=0
+12 SET $PIECE(^UTILITY($JOB,"PSOHLL",II),"^",8)=0
DO RPT
IF '$GET(^PSRX(HLINRX,"IB"))
QUIT
+13 IF $PIECE(^PSRX(HLINRX,"STA"),"^")>0
IF $PIECE(^("STA"),"^")'=2
IF '$GET(PSODBQ)
QUIT
+14 SET $PIECE(^UTILITY($JOB,"PSOHLL",II),"^",8)=1
End DoDot:1
+15 ;
AAA DO STRT^PSOHLSG5
+1 SET (HDFN,HDFN1)=$ORDER(^UTILITY($JOB,"PSOHLL",0))
SET HDFN=$PIECE(^PSRX($PIECE(^(HDFN),"^"),0),"^",2)
SET PSOLLL=$PIECE(^UTILITY($JOB,"PSOHLL",HDFN1),"^",12)
+2 FOR HLDFN=0:0
SET HLDFN=$ORDER(^UTILITY($JOB,"PSOHLL",HLDFN))
IF 'HLDFN
QUIT
Begin DoDot:1
+3 SET PSFLG=0
SET PSOLLN=$PIECE(^UTILITY($JOB,"PSOHLL",HLDFN),"^",12)
SET HNEWDFN=$PIECE(^PSRX($PIECE(^UTILITY($JOB,"PSOHLL",HLDFN),"^"),0),"^",2)
Begin DoDot:2
+4 IF HDFN'=HNEWDFN
SET HDFN=HNEWDFN
SET PSFLG=1
+5 IF PSOLLL'=PSOLLN
SET PSOLLL=PSOLLN
SET PSFLG=1
+6 IF PSFLG=1
DO SETZ
End DoDot:2
End DoDot:1
SET ^UTILITY($JOB,"PSOHL",HLDFN)=^UTILITY($JOB,"PSOHLL",HLDFN)
DO OTHER
+7 IF '$DATA(^UTILITY($JOB,"PSOHL"))
GOTO ENDHL
CALL DO SETZ
ENDHL KILL ^UTILITY($JOB,"PSOHL"),^UTILITY($JOB,"PSOHLL"),HLRXY
+1 QUIT
OTHER IF $GET(^UTILITY($JOB,"PSOHLL",HLDFN,"DRI"))'=""
SET ^UTILITY($JOB,"PSOHL",HLDFN,"DRI")=^UTILITY($JOB,"PSOHLL",HLDFN,"DRI")
+1 FOR HLDAI=0:0
SET HLDAI=$ORDER(^UTILITY($JOB,"PSOHLL",HLDFN,HLDAI))
IF 'HLDAI
QUIT
SET ^UTILITY($JOB,"PSOHL",HLDFN,HLDAI)=^UTILITY($JOB,"PSOHLL",HLDFN,HLDAI)
+2 QUIT
ACLOG ;Activity log (sending to Hl7 interface)
+1 NEW DTTM,HCOM,HCNT,HJJ
+2 DO NOW^%DTC
SET DTTM=%
SET HCOM="Prescription"_$SELECT($GET(RXPR(HLINRX)):" (Partial)",1:"")_$SELECT($GET(PSOSUREP)!($GET(RXRP(HLINRX))):" (Reprint)",1:"")_" sent to external interface."
+3 SET HCNT=0
FOR HJJ=0:0
SET HJJ=$ORDER(^PSRX(HLINRX,"A",HJJ))
IF 'HJJ
QUIT
SET HCNT=HJJ
+4 SET HCNT=HCNT+1
SET ^PSRX(HLINRX,"A",0)="^52.3DA^"_HCNT_"^"_HCNT
SET ^PSRX(HLINRX,"A",HCNT,0)=DTTM_"^X^"_$GET(PDUZ)_"^"_$SELECT($GET(RXPR(HLINRX)):6,$GET(HLFOUR)<6:$GET(HLFOUR),1:(HLFOUR+1))_"^"_HCOM
+5 QUIT
SUS(HSREX,HSFL,HSFILL,HSRP) ;
+1 NEW DA,DIK,DTTM,HSCOM,HSCNT,HSJJ,HSLDUZ,PSHLCPRS
+2 IF $PIECE($GET(^PSRX(HSREX,"STA")),"^")=5
SET $PIECE(^PSRX(HSREX,"STA"),"^")=0
SET PSHLCPRS="Removed from Suspense, External Interface."
DO EN^PSOHLSN1(HSREX,"SC","ZU",PSHLCPRS)
+3 SET DA=$ORDER(^PS(52.5,"B",HSREX,0))
IF DA
KILL DIK
SET DIK="^PS(52.5,"
DO ^DIK
+4 IF $GET(HSFL)="P"
SET HSLDUZ=+$PIECE($GET(^PSRX(HSREX,"P",HSFILL,0)),"^",7)
+5 IF '$TEST
SET HSLDUZ=$SELECT('HSFILL:+$PIECE($GET(^PSRX(HSREX,0)),"^",16),1:+$PIECE($GET(^PSRX(HSREX,1,HSFILL,0)),"^",7))
+6 DO NOW^%DTC
SET DTTM=%
SET HSCOM="Removed from Suspense"_$SELECT($GET(HSFL)="P":" (Partial)",1:"")_$SELECT($GET(HSRP):" (Reprint)",1:"")_" (External Interface)"
+7 SET HSCNT=0
FOR HSJJ=0:0
SET HSJJ=$ORDER(^PSRX(HSREX,"A",HSJJ))
IF 'HSJJ
QUIT
SET HSCNT=HSJJ
+8 SET HSCNT=HSCNT+1
SET ^PSRX(HSREX,"A",0)="^52.3DA^"_HSCNT_"^"_HSCNT
SET ^PSRX(HSREX,"A",HSCNT,0)=DTTM_"^X^"_$GET(HSLDUZ)_"^"_$SELECT($GET(HSFL)="P":6,$GET(HSFILL)<6:$GET(HSFILL),1:(HSFILL+1))_"^"_$GET(HSCOM)
+9 QUIT
LAB(HLREX,HLFL,HLFILL,HLREPT) ;
+1 NEW HLDUZ,NOW,DA,HCT,HFF
+2 DO NOW^%DTC
SET NOW=%
SET HCT=0
FOR HFF=0:0
SET HFF=$ORDER(^PSRX(HLREX,"L",HFF))
IF 'HFF
QUIT
SET HCT=HFF
+3 IF HLFL="F"
SET HLDUZ=$SELECT('HLFILL:+$PIECE($GET(^PSRX(HLREX,0)),"^",16),1:+$PIECE($GET(^PSRX(HLREX,1,HLFILL,0)),"^",7))
+4 IF HLFL="P"
SET HLDUZ=+$PIECE($GET(^PSRX(HLREX,"P",HLFILL,0)),"^",7)
+5 SET HCT=HCT+1
SET ^PSRX(HLREX,"L",0)="^52.032DA^"_HCT_"^"_HCT
+6 SET ^PSRX(HLREX,"L",HCT,0)=NOW_"^"_$SELECT($GET(HLFL)="F":HLFILL,1:(99-HLFILL))_"^"_"From Rx number "_$PIECE(^PSRX(HLREX,0),"^")_$SELECT($GET(HLFL)="P":" (Partial)",1:"")_$SELECT($GET(HLREPT):" (Reprint)",1:"")_" (External Interface)"_"^"_$GET(
HLDUZ)
+7 NEW PSOBADR,PSOTEMP
+8 SET PSOBADR=$$CHKRX^PSOBAI(HLREX)
+9 IF $GET(PSOBADR)
SET PSOTEMP=$PIECE(PSOBADR,"^",2)
SET PSOBADR=$PIECE(PSOBADR,"^")
+10 IF $GET(PSOBADR)
IF '$GET(PSOTEMP)
Begin DoDot:1
+11 SET HCT=HCT+1
SET ^PSRX(HLREX,"L",0)="^52.032DA^"_HCT_"^"_HCT
+12 SET ^PSRX(HLREX,"L",HCT,0)=NOW_"^"_$SELECT($GET(HLFL)="F":HLFILL,1:(99-HLFILL))_"^"_"ROUTING="_$GET(MW)_" (BAD ADDRESS)"_"^"_$GET(HLDUZ)
End DoDot:1
+13 QUIT
RPT ;
+1 SET $PIECE(^UTILITY($JOB,"PSOHLL",II),"^",9)=$SELECT($GET(PSOSUREP)!($GET(RXRP(HLINRX))):1,1:0)
+2 SET $PIECE(^UTILITY($JOB,"PSOHLL",II),"^",10)=+$GET(PDUZ)
+3 QUIT
SETZ ;
+1 DO NOW^%DTC
SET PSODTM=%
+2 SET ZTRTN=$SELECT($$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4:"INIT^PSOHLDS",1:"INIT^PSOHLSG")
+3 SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTSAVE("^UTILITY($J,""PSOHL"",")=""
SET ZTSAVE("PSOPAR")=""
SET ZTSAVE("PSOSITE")=""
SET ZTSAVE("PSODTM")=""
SET ZTSAVE("PSOLAP")=""
+4 SET ZTSAVE("RXRP(")=""
SET ZTSAVE("RXPR(")=""
SET ZTSAVE("RXFL(")=""
SET ZTSAVE("RXRS(")=""
+5 SET ZTDESC=$SELECT($$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4:"Outpatient Automation External Interface",1:"GENERIC INTERFACE LABEL INFORMATION")
+6 DO ^%ZTLOAD
+7 KILL ^UTILITY($JOB,"PSOHL")
+8 QUIT
