Routine: PSOLBL4

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

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)

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

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)

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)

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)

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")

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

PSOLBL4.m