PSOTPHL1 ;BPFO/EL-CREATE HL7 BATCH MESSAGE FILE ;09/10/03
;;7.0;OUTPATIENT PHARMACY;**146,153,227**;DEC 1997
;
; Summary:
; Use of ^VAFCQRY API is approved under private IA #3630
; For initial run, makes sure the "Transmission End Date" (#46.2) in
; File 59.7 - Pharmacy System File is null.
; If field (#46.2) is null, the system will pick up all DFN in File 52.91
; from the first date of file creation to the "RunDate"-1.
; If field (#46.2) has a date, the system will pick up DFN starting
; from the last "Transmission End Date"+1 to the "RunDate"-1.
; This program only runs on Sunday. RunTime will be 6pm.
; Tab: EN^PSOTPHL1(RDT,EDT,.SDT) is the ad-hoc entry point if user
; wants to run it at certain "Transmission Begin Date",
; "Transmission End Date", & return actual "Transmission Begin Date".
; If run is success, an audit node will be placed at File 59.7 as:
; ^PS(59.7,D0,46)=TransmissionStartDt_"^"_TransmissionEndDt_"^"_MshID_"^"_MshCnt_"^"_LineCnt
;
; At the end of each run, this program will send out mail to the mail
; group "PSO TPB HL7 EXTRACT" except the non-Sunday TaskMan check
;
Q ; placed out of order by PSO*7*227
N A,B,C,CK,EDT,ERR,FRTIME,I,L,R,RDT,SDT,SET,X
N BCNT,DATA,DFN,EVENT,LN,MCNT,PGM,PS,PSO
N BBDT,BEDT,DADT,EXC,INS,PADT,PN,REASON,STA,WAITYP
;
START S CK=0 D DATE I CK=1 G ENDS
;
D EN^PSOTPHL1(RDT,EDT,.SDT)
Q
;
DATE ; Check if first time run or Sunday
S (EDT,FRTIME,PS,SET)=0,PS=59.7
S EDT=$$GET1^DIQ(PS,"1,46",46.2,"I"),EDT=+EDT
D NOW^%DTC
D DW^%DTC
I EDT'>0 S FRTIME=1 G GDATE
I X'["SUN" S CK=1 Q
;
S SDT=EDT+1
GDATE S RDT="",SET=1
S RDT=$S(EDT:EDT,1:0)
S EDT=DT-1
Q
;
INIT ; Variable Initialization
S (BCNT,LN,MCNT,CK)=0
S PGM="PSOTPHL1"
S PSO=52.91
D INHL7
;
K ^TMP("HLS",$J),^TMP(PGM,$J,EDT)
;
Q
;
INHL7 S EVENT="PSO TPB EV"
I '$D(U) S U="^"
D INIT^HLFNC2(EVENT,.HL)
I $G(HL) S ERR=$P(HL,"^",2),CK=1 Q
D CREATE^HLTF(.HLMID,.HLDA,.HLDT,.HLDT1)
D INHD
Q
;
INHD I '$D(DTIME) S DTIME=0
I '$D(HL("DTM")) S HL("DTM")=HLDT1
I '$D(HL("FS")) S HL("FS")="^"
I '$D(HL("ECH")) S HL("ECH")="~|\&"
I '$D(HL("ETN")) S HL("ETN")="S12"
I '$D(HL("MTN")) S HL("MTN")="SIU"
I '$D(HL("MTN_ETN")) S HL("MTN_ETN")="SIU_S12"
I '$D(HL("PID")) S HL("PID")="P"
I '$D(HL("Q")) S HL("Q")=""""
I '$D(HL("VER")) S HL("VER")="2.4"
I '$D(HL("CC")) S HL("CC")="US"
I '$D(HL("ACAT")) S HL("ACAT")="AL"
I '$D(HL("APAT")) S HL("APAT")="NE"
I '$D(HL("SAN")) S HL("SAN")="PSO TPB-PHARM"
I '$D(HL("RAN")) S HL("RAN")="PSO TPB-ACC"
;
Q
;
BHS ; CREATE "BHS" SEGMENT
S BCNT=BCNT+1
S LN=LN+1
;
Q
;
EN(RDT,EDT,SDT) ; ENTRY POINT FOR PROCESS
D INIT I CK=1 G OUT
D BHS
D PROCESS
D BTS
G OUT
;
PROCESS ; Sort and Process the message body
I '$D(SET) S SDT=RDT,RDT=RDT-1
I $G(FRTIME)=1 D FRTIME
P10 S RDT=$O(^PS(PSO,"AX",RDT)) G P30:(RDT>EDT)!(RDT="")
I SDT>RDT S SDT=RDT
S DFN=""
P20 S DFN=$O(^PS(PSO,"AX",RDT,DFN)) G P10:DFN=""
I '$D(^PS(PSO,DFN,0)) K ^PS(PSO,"AX",RDT,DFN) G P20
S ^TMP(PGM,$J,EDT,"ZZ",DFN)=RDT
G P20
;
FRTIME ; To generate a complete data set for the frist time
S (DFN,RDT,X)=""
S SDT=999999999
F10 S DFN=$O(^PS(PSO,DFN)) Q:(DFN'?1N.N)!(DFN="")
I '$D(^PS(PSO,DFN,0)) G F10
S X=$P(^PS(PSO,DFN,0),"^",2)
I SDT>X S SDT=X
S ^TMP(PGM,$J,EDT,"ZZ",DFN)=X
G F10
;
P30 I '$D(^TMP(PGM,$J,EDT,"ZZ")) D G GEN
. S MCNT=0
. D MSH^HLFNC2(.HL,HLMID_"-"_MCNT,.X,"")
. D WRITE
;
S DFN=""
DFN S DFN=$O(^TMP(PGM,$J,EDT,"ZZ",DFN)) G GEN:DFN=""
S RDT=^TMP(PGM,$J,EDT,"ZZ",DFN)
D EXTRACT
D MSH
D SCH
D PID
G DFN
;
GEN S HLP="" D GENERATE^HLMA(EVENT,"GB",1,.R,HLDA,.HLP)
Q
;
S (A,B,BBDT,BEDT,C,DADT,DATA,EXC,INS,PADT,PN,REASON,STA,WAITYP,X)=""
S X=^PS(PSO,DFN,0)
S DATA="PN,BBDT,BEDT,REASON,DADT,WAITYP,STA,INS,EXC,PADT"
F I=1:1:10 S @$P(DATA,",",I)=$P(X,"^",I)
I $D(PADT) S PADT=$P(PADT,".")
I +BBDT=+RDT S HL("ETN")="S12"
E S HL("ETN")="S14"
S HL("MTN_ETN")=HL("MTN")_"_"_HL("ETN")
S A="BBDT,BEDT,DADT,PADT"
F I=1:1:4 S B=$P(A,",",I) I $G(@B)>0 S C=$$HLDATE^HLFNC(@B,"DT"),@$P(A,",",I)=C
Q
;
MSH ; CREATE "MSH" SEGMENT
S MCNT=MCNT+1
D MSH^HLFNC2(.HL,HLMID_"-"_MCNT,.X,"")
;
D WRITE
Q
;
SCH ; CREATE "SCH" SEGMENT
K SCH S (X,A,B,C)="",I=0 S:REASON>9 REASON=9
S X="Seen by VA Provider,No/Show/Cancellation,Patient Ended"
S X=X_",Non-Formulary Rx not accepted,Patient Expired,All Rx's Inactive"
S X=X_",Exclusion,Patient Refused Appointment,Patient Unreachable"
S A=$P(X,",",REASON)
;
S X="" S:EXC>3 EXC=3
S X="Excluded due to active Rx#"
S X=X_",Excluded due to actual appt<30 days from desired appt date"
S X=X_",Exclued due to active Rx# and actual appt<30 days from desired appt date"
S B=$P(X,",",EXC)
;
I WAITYP="E" S C="EWL"
E I WAITYP="M" S C="Manual"
E I WAITYP="S" S C="Schedule"
E S C="S\T\E"
;
S X=""
S X=HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_REASON_"~"_A
S X=X_HL("FS")_EXC_"~"_B_HL("FS")_WAITYP_"~"_C
S X=X_HL("FS")_HL("FS")_HL("FS")
S I=I+1,SCH(I)="SCH"_X
;
S X="",X=X_"~~~"_DADT_"~~~~Desired Appointment Date|~~~"
S X=X_PADT_"~~~~Primary Care Scheduled Appointment Date|~~~"
S X=X_BBDT_"~~~~Date Pharmacy Benefit Began|~~~"
S X=X_BEDT_"~~~~Inactivation of Benefit Date|~~~"
S X=X_$$HLDATE^HLFNC(RDT,"DT")_"~~~~Record Change Date"
I $L(SCH(I)_X)<246 S SCH(I)=SCH(I)_X
E S I=I+1,SCH(I)=X
;
S X="",$P(X,"^",12)=STA_"~~~"_INS_"&"_$$GET1^DIQ(4,INS_",0",.01)
I $L(SCH(I)_X)<246 S SCH(I)=SCH(I)_X
E S I=I+1,SCH(I)=X
;
F I=1:1 S X=$G(SCH(I)) Q:X="" D
. I I=1 D WRITE
. E D WRITEN
Q
;
PID ; CREATE "PID" SEGMENT
K PID
D DEM^VADPT,ADD^VADPT
D BLDPID^PSOTPHL2(DFN,1,.PID,.HL,.ERR)
Q:$G(PID(1))=""
S X=""
F I=1:1 S X=$G(PID(I)) Q:X="" D
. I I=1 D WRITE
. E D WRITEN
Q
;
BTS ; CREATE "BTS" SEGMENT
S LN=LN+1
Q
;
WRITE ; Write single line
S LN=LN+1
S ^TMP("HLS",$J,LN)=X
Q
;
WRITEN ; Write multiple lines
S ^TMP("HLS",$J,LN,I-1)=X
Q
;
CLEANUP ; Clean up variables
K A,B,C,CK,EDT,ERR,I,L,R,RDT,SDT,X
K BCNT,DATA,DFN,EVENT,LN,MCNT,PGM,PS,PSO
K BBDT,BEDT,DADT,EXC,INS,PADT,PN,REASON,STA,WAITYP
Q
;
OUT ; End of compilation
I CK=1 G END
K ^TMP("HLS",$J),^TMP(PGM,$J,EDT),PID,SCH
I SDT>EDT S SDT=EDT
I $G(SET)=1 S ^PS(PS,1,46)=SDT_"^"_EDT_"^"_HLDA_"^"_MCNT_"^"_LN
;
END D MAIL
I $G(SET)'=1 D CLEANUP
ENDS I $G(FRTIME)=1 D RESET
S:$D(ZTQUEUED) ZTREQ="@"
Q
;
RESET ; Reset to run tomorrow
D RESCH^XUTMOPT("PSO TPB HL7 EXTRACT","T+1@18:00","","24H","L")
Q
;
RESET1 ; Reset to run tomorrow
D RESET,EDIT^XUTMOPT("PSO TPB HL7 EXTRACT")
Q
;
MAIL ;Send mail message
I '$G(DUZ) Q
K PSOTTEXT,XMY S (XMDUZ,XMSUB,XMTEST,A,B,C,I,L,R,X)=""
S C="G.PSO TPB HL7 EXTRACT"
S XMY(C)=""
S PSOTTEXT(1)="SENT TO: "_C
S XMDUZ="PSO TPB HL7 EXTRACT"
S (A,B)=""
I '$D(SET) S A="Ad-Hoc"
E S A=$S(($G(FRTIME)=1):"first-time",1:"weekly")
S B=$S(($G(CK)=1):"unsuccessful",1:"successful")
S XMSUB="PSO TPB HL7 "_A_" update ** "_B_" **"
S A=XMSUB
I $G(CK)=1 D FAIL
E D SUCC
S PSOTTEXT(2)=" "
S PSOTTEXT(3)="The weekly generation of the HL7 Message of"
S PSOTTEXT(3.2)="TPB Patient Information was "_B
S PSOTTEXT(4)=""
S PSOTTEXT(5)=I
S PSOTTEXT(6)=L
S PSOTTEXT(6.2)=R
S PSOTTEXT(6.4)=X
S PSOTTEXT(7)=" "
D NOW^%DTC S Y=% X ^DD("DD") S PSOTTEXT(8)="The job ended at "_$G(Y)
S PSOTTEXT(9)=" "
S XMTEXT="PSOTTEXT(" N DIFROM D ^XMD
I $D(XMMG),(XMMG["Error =") D
. K XMY(C)
. S XMSUB=A,XMY(DUZ)="",PSOTTEXT(1)=PSOTTEXT(1)_" ("_XMMG_")",XMMG=""
. S XMTEXT="PSOTTEXT(" D ^XMD
K PSOTTEXT,XMDUZ,XMSUB,XMTEXT,XMY
Q
FAIL ; Msg for unsuccessful run
S I="Reason: "_$S(($D(ERR)):ERR,1:"Check Event Server Protocol OR the run date")
S L=" "
S R="Please contact National Help Desk @888-596-4357"
S X=" "
Q
;
SUCC ; Msg for successful run
S I="Please check the PSOTPBAAC HL7 Logical Link to ensure"
S L="successful transmission to the Austin Automation Center."
S R=" "
S X="MSH-ID: "_HLDA
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOTPHL1 8190 printed Dec 13, 2024@02:35:54 Page 2
PSOTPHL1 ;BPFO/EL-CREATE HL7 BATCH MESSAGE FILE ;09/10/03
+1 ;;7.0;OUTPATIENT PHARMACY;**146,153,227**;DEC 1997
+2 ;
+3 ; Summary:
+4 ; Use of ^VAFCQRY API is approved under private IA #3630
+5 ; For initial run, makes sure the "Transmission End Date" (#46.2) in
+6 ; File 59.7 - Pharmacy System File is null.
+7 ; If field (#46.2) is null, the system will pick up all DFN in File 52.91
+8 ; from the first date of file creation to the "RunDate"-1.
+9 ; If field (#46.2) has a date, the system will pick up DFN starting
+10 ; from the last "Transmission End Date"+1 to the "RunDate"-1.
+11 ; This program only runs on Sunday. RunTime will be 6pm.
+12 ; Tab: EN^PSOTPHL1(RDT,EDT,.SDT) is the ad-hoc entry point if user
+13 ; wants to run it at certain "Transmission Begin Date",
+14 ; "Transmission End Date", & return actual "Transmission Begin Date".
+15 ; If run is success, an audit node will be placed at File 59.7 as:
+16 ; ^PS(59.7,D0,46)=TransmissionStartDt_"^"_TransmissionEndDt_"^"_MshID_"^"_MshCnt_"^"_LineCnt
+17 ;
+18 ; At the end of each run, this program will send out mail to the mail
+19 ; group "PSO TPB HL7 EXTRACT" except the non-Sunday TaskMan check
+20 ;
+21 ; placed out of order by PSO*7*227
QUIT
+22 NEW A,B,C,CK,EDT,ERR,FRTIME,I,L,R,RDT,SDT,SET,X
+23 NEW BCNT,DATA,DFN,EVENT,LN,MCNT,PGM,PS,PSO
+24 NEW BBDT,BEDT,DADT,EXC,INS,PADT,PN,REASON,STA,WAITYP
+25 ;
START SET CK=0
DO DATE
IF CK=1
GOTO ENDS
+1 ;
+2 DO EN^PSOTPHL1(RDT,EDT,.SDT)
+3 QUIT
+4 ;
DATE ; Check if first time run or Sunday
+1 SET (EDT,FRTIME,PS,SET)=0
SET PS=59.7
+2 SET EDT=$$GET1^DIQ(PS,"1,46",46.2,"I")
SET EDT=+EDT
+3 DO NOW^%DTC
+4 DO DW^%DTC
+5 IF EDT'>0
SET FRTIME=1
GOTO GDATE
+6 IF X'["SUN"
SET CK=1
QUIT
+7 ;
+8 SET SDT=EDT+1
GDATE SET RDT=""
SET SET=1
+1 SET RDT=$SELECT(EDT:EDT,1:0)
+2 SET EDT=DT-1
+3 QUIT
+4 ;
INIT ; Variable Initialization
+1 SET (BCNT,LN,MCNT,CK)=0
+2 SET PGM="PSOTPHL1"
+3 SET PSO=52.91
+4 DO INHL7
+5 ;
+6 KILL ^TMP("HLS",$JOB),^TMP(PGM,$JOB,EDT)
+7 ;
+8 QUIT
+9 ;
INHL7 SET EVENT="PSO TPB EV"
+1 IF '$DATA(U)
SET U="^"
+2 DO INIT^HLFNC2(EVENT,.HL)
+3 IF $GET(HL)
SET ERR=$PIECE(HL,"^",2)
SET CK=1
QUIT
+4 DO CREATE^HLTF(.HLMID,.HLDA,.HLDT,.HLDT1)
+5 DO INHD
+6 QUIT
+7 ;
INHD IF '$DATA(DTIME)
SET DTIME=0
+1 IF '$DATA(HL("DTM"))
SET HL("DTM")=HLDT1
+2 IF '$DATA(HL("FS"))
SET HL("FS")="^"
+3 IF '$DATA(HL("ECH"))
SET HL("ECH")="~|\&"
+4 IF '$DATA(HL("ETN"))
SET HL("ETN")="S12"
+5 IF '$DATA(HL("MTN"))
SET HL("MTN")="SIU"
+6 IF '$DATA(HL("MTN_ETN"))
SET HL("MTN_ETN")="SIU_S12"
+7 IF '$DATA(HL("PID"))
SET HL("PID")="P"
+8 IF '$DATA(HL("Q"))
SET HL("Q")=""""
+9 IF '$DATA(HL("VER"))
SET HL("VER")="2.4"
+10 IF '$DATA(HL("CC"))
SET HL("CC")="US"
+11 IF '$DATA(HL("ACAT"))
SET HL("ACAT")="AL"
+12 IF '$DATA(HL("APAT"))
SET HL("APAT")="NE"
+13 IF '$DATA(HL("SAN"))
SET HL("SAN")="PSO TPB-PHARM"
+14 IF '$DATA(HL("RAN"))
SET HL("RAN")="PSO TPB-ACC"
+15 ;
+16 QUIT
+17 ;
BHS ; CREATE "BHS" SEGMENT
+1 SET BCNT=BCNT+1
+2 SET LN=LN+1
+3 ;
+4 QUIT
+5 ;
EN(RDT,EDT,SDT) ; ENTRY POINT FOR PROCESS
+1 DO INIT
IF CK=1
GOTO OUT
+2 DO BHS
+3 DO PROCESS
+4 DO BTS
+5 GOTO OUT
+6 ;
PROCESS ; Sort and Process the message body
+1 IF '$DATA(SET)
SET SDT=RDT
SET RDT=RDT-1
+2 IF $GET(FRTIME)=1
DO FRTIME
P10 SET RDT=$ORDER(^PS(PSO,"AX",RDT))
if (RDT>EDT)!(RDT="")
GOTO P30
+1 IF SDT>RDT
SET SDT=RDT
+2 SET DFN=""
P20 SET DFN=$ORDER(^PS(PSO,"AX",RDT,DFN))
if DFN=""
GOTO P10
+1 IF '$DATA(^PS(PSO,DFN,0))
KILL ^PS(PSO,"AX",RDT,DFN)
GOTO P20
+2 SET ^TMP(PGM,$JOB,EDT,"ZZ",DFN)=RDT
+3 GOTO P20
+4 ;
FRTIME ; To generate a complete data set for the frist time
+1 SET (DFN,RDT,X)=""
+2 SET SDT=999999999
F10 SET DFN=$ORDER(^PS(PSO,DFN))
if (DFN'?1N.N)!(DFN="")
QUIT
+1 IF '$DATA(^PS(PSO,DFN,0))
GOTO F10
+2 SET X=$PIECE(^PS(PSO,DFN,0),"^",2)
+3 IF SDT>X
SET SDT=X
+4 SET ^TMP(PGM,$JOB,EDT,"ZZ",DFN)=X
+5 GOTO F10
+6 ;
P30 IF '$DATA(^TMP(PGM,$JOB,EDT,"ZZ"))
Begin DoDot:1
+1 SET MCNT=0
+2 DO MSH^HLFNC2(.HL,HLMID_"-"_MCNT,.X,"")
+3 DO WRITE
End DoDot:1
GOTO GEN
+4 ;
+5 SET DFN=""
DFN SET DFN=$ORDER(^TMP(PGM,$JOB,EDT,"ZZ",DFN))
if DFN=""
GOTO GEN
+1 SET RDT=^TMP(PGM,$JOB,EDT,"ZZ",DFN)
+2 DO EXTRACT
+3 DO MSH
+4 DO SCH
+5 DO PID
+6 GOTO DFN
+7 ;
GEN SET HLP=""
DO GENERATE^HLMA(EVENT,"GB",1,.R,HLDA,.HLP)
+1 QUIT
+2 ;
+1 SET (A,B,BBDT,BEDT,C,DADT,DATA,EXC,INS,PADT,PN,REASON,STA,WAITYP,X)=""
+2 SET X=^PS(PSO,DFN,0)
+3 SET DATA="PN,BBDT,BEDT,REASON,DADT,WAITYP,STA,INS,EXC,PADT"
+4 FOR I=1:1:10
SET @$PIECE(DATA,",",I)=$PIECE(X,"^",I)
+5 IF $DATA(PADT)
SET PADT=$PIECE(PADT,".")
+6 IF +BBDT=+RDT
SET HL("ETN")="S12"
+7 IF '$TEST
SET HL("ETN")="S14"
+8 SET HL("MTN_ETN")=HL("MTN")_"_"_HL("ETN")
+9 SET A="BBDT,BEDT,DADT,PADT"
+10 FOR I=1:1:4
SET B=$PIECE(A,",",I)
IF $GET(@B)>0
SET C=$$HLDATE^HLFNC(@B,"DT")
SET @$PIECE(A,",",I)=C
+11 QUIT
+12 ;
MSH ; CREATE "MSH" SEGMENT
+1 SET MCNT=MCNT+1
+2 DO MSH^HLFNC2(.HL,HLMID_"-"_MCNT,.X,"")
+3 ;
+4 DO WRITE
+5 QUIT
+6 ;
SCH ; CREATE "SCH" SEGMENT
+1 KILL SCH
SET (X,A,B,C)=""
SET I=0
if REASON>9
SET REASON=9
+2 SET X="Seen by VA Provider,No/Show/Cancellation,Patient Ended"
+3 SET X=X_",Non-Formulary Rx not accepted,Patient Expired,All Rx's Inactive"
+4 SET X=X_",Exclusion,Patient Refused Appointment,Patient Unreachable"
+5 SET A=$PIECE(X,",",REASON)
+6 ;
+7 SET X=""
if EXC>3
SET EXC=3
+8 SET X="Excluded due to active Rx#"
+9 SET X=X_",Excluded due to actual appt<30 days from desired appt date"
+10 SET X=X_",Exclued due to active Rx# and actual appt<30 days from desired appt date"
+11 SET B=$PIECE(X,",",EXC)
+12 ;
+13 IF WAITYP="E"
SET C="EWL"
+14 IF '$TEST
IF WAITYP="M"
SET C="Manual"
+15 IF '$TEST
IF WAITYP="S"
SET C="Schedule"
+16 IF '$TEST
SET C="S\T\E"
+17 ;
+18 SET X=""
+19 SET X=HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_REASON_"~"_A
+20 SET X=X_HL("FS")_EXC_"~"_B_HL("FS")_WAITYP_"~"_C
+21 SET X=X_HL("FS")_HL("FS")_HL("FS")
+22 SET I=I+1
SET SCH(I)="SCH"_X
+23 ;
+24 SET X=""
SET X=X_"~~~"_DADT_"~~~~Desired Appointment Date|~~~"
+25 SET X=X_PADT_"~~~~Primary Care Scheduled Appointment Date|~~~"
+26 SET X=X_BBDT_"~~~~Date Pharmacy Benefit Began|~~~"
+27 SET X=X_BEDT_"~~~~Inactivation of Benefit Date|~~~"
+28 SET X=X_$$HLDATE^HLFNC(RDT,"DT")_"~~~~Record Change Date"
+29 IF $LENGTH(SCH(I)_X)<246
SET SCH(I)=SCH(I)_X
+30 IF '$TEST
SET I=I+1
SET SCH(I)=X
+31 ;
+32 SET X=""
SET $PIECE(X,"^",12)=STA_"~~~"_INS_"&"_$$GET1^DIQ(4,INS_",0",.01)
+33 IF $LENGTH(SCH(I)_X)<246
SET SCH(I)=SCH(I)_X
+34 IF '$TEST
SET I=I+1
SET SCH(I)=X
+35 ;
+36 FOR I=1:1
SET X=$GET(SCH(I))
if X=""
QUIT
Begin DoDot:1
+37 IF I=1
DO WRITE
+38 IF '$TEST
DO WRITEN
End DoDot:1
+39 QUIT
+40 ;
PID ; CREATE "PID" SEGMENT
+1 KILL PID
+2 DO DEM^VADPT
DO ADD^VADPT
+3 DO BLDPID^PSOTPHL2(DFN,1,.PID,.HL,.ERR)
+4 if $GET(PID(1))=""
QUIT
+5 SET X=""
+6 FOR I=1:1
SET X=$GET(PID(I))
if X=""
QUIT
Begin DoDot:1
+7 IF I=1
DO WRITE
+8 IF '$TEST
DO WRITEN
End DoDot:1
+9 QUIT
+10 ;
BTS ; CREATE "BTS" SEGMENT
+1 SET LN=LN+1
+2 QUIT
+3 ;
WRITE ; Write single line
+1 SET LN=LN+1
+2 SET ^TMP("HLS",$JOB,LN)=X
+3 QUIT
+4 ;
WRITEN ; Write multiple lines
+1 SET ^TMP("HLS",$JOB,LN,I-1)=X
+2 QUIT
+3 ;
CLEANUP ; Clean up variables
+1 KILL A,B,C,CK,EDT,ERR,I,L,R,RDT,SDT,X
+2 KILL BCNT,DATA,DFN,EVENT,LN,MCNT,PGM,PS,PSO
+3 KILL BBDT,BEDT,DADT,EXC,INS,PADT,PN,REASON,STA,WAITYP
+4 QUIT
+5 ;
OUT ; End of compilation
+1 IF CK=1
GOTO END
+2 KILL ^TMP("HLS",$JOB),^TMP(PGM,$JOB,EDT),PID,SCH
+3 IF SDT>EDT
SET SDT=EDT
+4 IF $GET(SET)=1
SET ^PS(PS,1,46)=SDT_"^"_EDT_"^"_HLDA_"^"_MCNT_"^"_LN
+5 ;
END DO MAIL
+1 IF $GET(SET)'=1
DO CLEANUP
ENDS IF $GET(FRTIME)=1
DO RESET
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 QUIT
+3 ;
RESET ; Reset to run tomorrow
+1 DO RESCH^XUTMOPT("PSO TPB HL7 EXTRACT","T+1@18:00","","24H","L")
+2 QUIT
+3 ;
RESET1 ; Reset to run tomorrow
+1 DO RESET
DO EDIT^XUTMOPT("PSO TPB HL7 EXTRACT")
+2 QUIT
+3 ;
MAIL ;Send mail message
+1 IF '$GET(DUZ)
QUIT
+2 KILL PSOTTEXT,XMY
SET (XMDUZ,XMSUB,XMTEST,A,B,C,I,L,R,X)=""
+3 SET C="G.PSO TPB HL7 EXTRACT"
+4 SET XMY(C)=""
+5 SET PSOTTEXT(1)="SENT TO: "_C
+6 SET XMDUZ="PSO TPB HL7 EXTRACT"
+7 SET (A,B)=""
+8 IF '$DATA(SET)
SET A="Ad-Hoc"
+9 IF '$TEST
SET A=$SELECT(($GET(FRTIME)=1):"first-time",1:"weekly")
+10 SET B=$SELECT(($GET(CK)=1):"unsuccessful",1:"successful")
+11 SET XMSUB="PSO TPB HL7 "_A_" update ** "_B_" **"
+12 SET A=XMSUB
+13 IF $GET(CK)=1
DO FAIL
+14 IF '$TEST
DO SUCC
+15 SET PSOTTEXT(2)=" "
+16 SET PSOTTEXT(3)="The weekly generation of the HL7 Message of"
+17 SET PSOTTEXT(3.2)="TPB Patient Information was "_B
+18 SET PSOTTEXT(4)=""
+19 SET PSOTTEXT(5)=I
+20 SET PSOTTEXT(6)=L
+21 SET PSOTTEXT(6.2)=R
+22 SET PSOTTEXT(6.4)=X
+23 SET PSOTTEXT(7)=" "
+24 DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
SET PSOTTEXT(8)="The job ended at "_$GET(Y)
+25 SET PSOTTEXT(9)=" "
+26 SET XMTEXT="PSOTTEXT("
NEW DIFROM
DO ^XMD
+27 IF $DATA(XMMG)
IF (XMMG["Error =")
Begin DoDot:1
+28 KILL XMY(C)
+29 SET XMSUB=A
SET XMY(DUZ)=""
SET PSOTTEXT(1)=PSOTTEXT(1)_" ("_XMMG_")"
SET XMMG=""
+30 SET XMTEXT="PSOTTEXT("
DO ^XMD
End DoDot:1
+31 KILL PSOTTEXT,XMDUZ,XMSUB,XMTEXT,XMY
+32 QUIT
FAIL ; Msg for unsuccessful run
+1 SET I="Reason: "_$SELECT(($DATA(ERR)):ERR,1:"Check Event Server Protocol OR the run date")
+2 SET L=" "
+3 SET R="Please contact National Help Desk @888-596-4357"
+4 SET X=" "
+5 QUIT
+6 ;
SUCC ; Msg for successful run
+1 SET I="Please check the PSOTPBAAC HL7 Logical Link to ensure"
+2 SET L="successful transmission to the Austin Automation Center."
+3 SET R=" "
+4 SET X="MSH-ID: "_HLDA
+5 QUIT
+6 ;
