- 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 Feb 19, 2025@00:00:09 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