PSORELDT ;BIR/PWC-HL7 V.2.4 EXTERNAL INTERFACE RELEASE DATE/TIME ;01/05/04 09:45
;;7.0;OUTPATIENT PHARMACY;**156**;DEC 1997
;PS(51.2 supp. by DBIA 2226
;GETAPP^HLCS2 supported by DBIA 2887
;INIT^HLFNC2 supported by DBIA 2161
;GENERATE^HLMA supported by DBIA 2164
;SETUP^XQALERT supported by DBIA 10081
;XUSEC("PSOINTERFACE" supported by DBIA 10076
;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") I $P($G(PSOHLINX),"^",2)="i" Q
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"),CS=$E(HL1("ECH")),RS=$E(HL1("ECH"),2),EC=$E(HL1("ECH"),3),SCS=$E(HL1("ECH"),4)
F II=0:0 S II=$O(^UTILITY($J,"PSOHL",II)) Q:'II D
.S ODR=$G(^UTILITY($J,"PSOHL",II)),IRXN=$P(ODR,"^"),IDGN=$P(^PSRX(IRXN,0),"^",2),PSODTM=$P(ODR,"^",3)
.I '$G(PSODTM) D NOW^%DTC S DTME=%
.I $G(PSODTM) S DTME=PSODTM
.S PRSN=$P(ODR,"^",4),RPRT=$P(ODR,"^",5),DIV=$G(PSOSITE),FPN=$P(ODR,"^",9)
.S DFN=$P(^PSRX(IRXN,0),"^",2),STPMTR=$P($G(^PS(59,DIV,1)),"^",30)
.K 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_";9////"_FPN_";15////"_DIV_";13////"_"BUILDING MESSAGE"_";14////1"
.D FILE^DICN K DD,DO,Y,DIC
.D ^PSORELD1
K ^TMP("HLS",$J)
M ^TMP("HLS",$J)=^TMP("PSO",$J)
S HLP("CONTPTR")="",HLP("SUBSCRIBER")="^^^^"_$P(^PS(59,PSOSITE,0),"^",6)_"~"_$P(^PS(59,PSOSITE,0),"^")_"~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 S II="" F 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,^TMP("PSO",$J),DFN,PAS,STPMTR,X,III,PIEN,PRSN,RPRT
K ^TMP("HLS",$J) ;keep around for testing
Q
;
ERRMSG S EMSG=""
F AA=1:1 X HLNEXT Q:HLQUIT'>0 S EMSG=EMSG_"&&"_HLNODE
S ^TMP("PSO2",$J)=EMSG
Q
ALERT ;turn off transmission and send alert to key holders
S:$G(PSOSITE) $P(^PS(59,PSOSITE,0),"^",30)=0
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORELDT 3154 printed Sep 23, 2025@20:10:10 Page 2
PSORELDT ;BIR/PWC-HL7 V.2.4 EXTERNAL INTERFACE RELEASE DATE/TIME ;01/05/04 09:45
+1 ;;7.0;OUTPATIENT PHARMACY;**156**;DEC 1997
+2 ;PS(51.2 supp. by DBIA 2226
+3 ;GETAPP^HLCS2 supported by DBIA 2887
+4 ;INIT^HLFNC2 supported by DBIA 2161
+5 ;GENERATE^HLMA supported by DBIA 2164
+6 ;SETUP^XQALERT supported by DBIA 10081
+7 ;XUSEC("PSOINTERFACE" supported by DBIA 10076
+8 ;ORD(101 supported by DBIA 872
+9 ;
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")
SET CS=$EXTRACT(HL1("ECH"))
SET RS=$EXTRACT(HL1("ECH"),2)
SET EC=$EXTRACT(HL1("ECH"),3)
SET SCS=$EXTRACT(HL1("ECH"),4)
+7 FOR II=0:0
SET II=$ORDER(^UTILITY($JOB,"PSOHL",II))
if 'II
QUIT
Begin DoDot:1
+8 SET ODR=$GET(^UTILITY($JOB,"PSOHL",II))
SET IRXN=$PIECE(ODR,"^")
SET IDGN=$PIECE(^PSRX(IRXN,0),"^",2)
SET PSODTM=$PIECE(ODR,"^",3)
+9 IF '$GET(PSODTM)
DO NOW^%DTC
SET DTME=%
+10 IF $GET(PSODTM)
SET DTME=PSODTM
+11 SET PRSN=$PIECE(ODR,"^",4)
SET RPRT=$PIECE(ODR,"^",5)
SET DIV=$GET(PSOSITE)
SET FPN=$PIECE(ODR,"^",9)
+12 SET DFN=$PIECE(^PSRX(IRXN,0),"^",2)
SET STPMTR=$PIECE($GET(^PS(59,DIV,1)),"^",30)
+13 KILL DIC,DA,DD,DO
+14 SET DIC="^PS(52.51,"
SET X=IRXN
SET DIC(0)=""
+15 SET DIC("DR")="2////"_DFN_";3////"_DTME_";4////"_PRSN_";5////"_RPRT_";6////"_STPMTR_";9////"_FPN_";15////"_DIV_";13////"_"BUILDING MESSAGE"_";14////1"
+16 DO FILE^DICN
KILL DD,DO,Y,DIC
+17 DO ^PSORELD1
End DoDot:1
+18 KILL ^TMP("HLS",$JOB)
+19 MERGE ^TMP("HLS",$JOB)=^TMP("PSO",$JOB)
+20 SET HLP("CONTPTR")=""
SET HLP("SUBSCRIBER")="^^^^"_$PIECE(^PS(59,PSOSITE,0),"^",6)_"~"_$PIECE(^PS(59,PSOSITE,0),"^")_"~DNS"
+21 DO GENERATE^HLMA(PIEN,"GM",1,.HLRESLT,"",.HLP)
+22 KILL HLL
SET HLMID=$PIECE($GET(HLRESLT),"^")
SET HLERR=$PIECE($GET(HLRESLT),"^",2)
+23 IF '$GET(HLMID)
SET XQAMSG="Error transmitting "_$PIECE(^DPT(DFN,0),"^")_" order to external interface"
DO ALERT
GOTO EXIT
+24 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
+25 IF $GET(HLMID)
IF $PIECE($GET(HLERR),"^")=""
SET MESS="MESSAGE TRANSMITTED"
SET STA=1
DO UFILE
GOTO EXIT
UFILE SET II=""
FOR
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,^TMP("PSO",$JOB),DFN,PAS,STPMTR,X,III,PIEN,PRSN,RPRT
+3 ;keep around for testing
KILL ^TMP("HLS",$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
ALERT ;turn off transmission and send alert to key holders
+1 if $GET(PSOSITE)
SET $PIECE(^PS(59,PSOSITE,0),"^",30)=0
+2 KILL XQA,XQAOPT,XQAROU,XQAID,XQADATA,XQAFLAG
+3 FOR UID=0:0
SET UID=$ORDER(^XUSEC("PSOINTERFACE",UID))
if 'UID
QUIT
SET XQA(UID)=""
+4 DO SETUP^XQALERT
+5 QUIT
