PSULRHL3 ;HCIOFO/BH - Daily file procesing ; 1/20/11 3:03pm
;;4.0;PHARMACY BENEFITS MANAGEMENT;**3,18**;MARCH, 2005;Build 7
;
; ** THIS ROUTINE SHOULD NEVER BE INSTALLED AT A SITE ***
; ** THIS ROUTINE IS ONLY TO BE RUN ON THE CMOP-NAT SERVER ***
;
Q
;
PROCESS ; This process loops through the file containing parsed HL7 data.
; This process runs each day and collects up to the previous days data.
; The data is ordered by facility. All the data for the facility for
; for up to the previous day gets filed into one flat file for PBM to
; process. A pre-init sub routine CULL loops through all x-refs that
; indicate processed data for facility and date and culls the data and
; removes the FD x-ref.
;
;
D CULL
;
;
N DFN,EDATE,FACILITY,FILE,IEN,OPEN,OUTDIR,PSUDTE,QUIT,RDATE,RC,SDATE,TEMP,X,X1,X2
;
; End date for search
D NOW^%DTC S TEMP=%,EDATE=$P(TEMP,".",1)
; Run date i.e. going to process data up to yesterday
S X1=$P(TEMP,".",1),X2="-1" D C^%DTC S RDATE=$P(X,".",1)
;
;
S FACILITY="",(QUIT,OPEN)=0
;
F S FACILITY=$O(^DIZ(99999,"FDP",FACILITY)) Q:'FACILITY!(QUIT) D
. ;
. I $D(^DIZ(99999,"FD",FACILITY,RDATE)) D Q
. . D ERROR(3,FACILITY,RDATE) Q
. ; New facility so close any open files.
. I OPEN D CLOSE S OPEN=0
. S DATE="0"
. F S DATE=$O(^DIZ(99999,"FDP",FACILITY,DATE)) Q:'DATE!(DATE'<EDATE)!(QUIT) D
. . ;
. . S DFN=""
. . F S DFN=$O(^DIZ(99999,"FDP",FACILITY,DATE,DFN)) Q:'DFN!(QUIT) D
. . . S IEN=""
. . . F S IEN=$O(^DIZ(99999,"FDP",FACILITY,DATE,DFN,IEN)) Q:'IEN!(QUIT) D
. . . . I 'OPEN D Q:'RC
. . . . . S RC=$$OPEN()
. . . . . I 'RC S QUIT=1 Q
. . . . . S OPEN=1
. . . . D FILE
I OPEN D CLOSE
Q
;
;
OPEN() ; Open the output directory
N DST,POP,SRC
S FILE=FACILITY_DT_".DAT"
;S OUTDIR="W:\PBM\National-PBM"
S OUTDIR="USER$:[PBM.LAB]"
;
K DST,SRC
S SRC(FILE)=""
I $$LIST^%ZISH(OUTDIR,"SRC","DST") D ERROR(2,FACILITY,FILE) Q 0
;
D OPEN^%ZISH("HL7FILE",OUTDIR,FILE,"W")
I $G(POP) D ERROR(1,FACILITY,OUTDIR_FILE) Q 0
;
Q 1
;
CLOSE ; Set Cross ref indicating that facilities data for the day got
; processed, and close the output file.
N FDA
K FDA
S FDA(99999,"+1,",.01)=$E(FILE,1,3)
S FDA(99999,"+1,",.03)=RDATE
D UPDATE^DIE("","FDA",)
D CLOSE^%ZISH("HL7FILE")
Q
;
FILE ; File the lab data to the output file in the following single string format.
;
; PSU*4*18 Add use of STA5A
; PAT|Facility|ICN|SSN|DFN|Date/Time Specimen Collected|STA5A|Site/Specimen|Local Lab Number^Local Lab Name|
; NLT Code^NLT Name|LOINC Code^LOINC Name|Result|Units|Low Range|High Range|
;
;
N CNT,CR,DFN,FAC,HRANGE,ICN,LABA,LABB,LABC,LNCODE,LNNAME,LOCALLAB
N LRANGE,NLTCODE,NLTNAME,RANGE,REC,RESIEN,RESREC,RESREC1,RESULT,SPEC
N SPECDATE,SPECREC,SPECIEN,SSN,STR,STR1,TEST,UNITS,STA5A
;
U IO
S REC=^DIZ(99999,IEN,0)
S SSN=$P(REC,U,5),ICN=$P(REC,U,4),FAC=$P(REC,U,1),DFN=$P(REC,U,2),STA5A=$P(REC,U,6)
;
S SPECIEN=0
F S SPECIEN=$O(^DIZ(99999,IEN,1,SPECIEN)) Q:'SPECIEN D
. ; Do not file if Specimen has no results
. S TEST=0
. S TEST=$O(^DIZ(99999,IEN,1,SPECIEN,1,TEST)) Q:'TEST
. S SPECREC=^DIZ(99999,IEN,1,SPECIEN,0)
. S SPEC=$P(SPECREC,U,1),SPECDATE=$P(SPECREC,U,2)
. S STR="PAT|"_FAC_"|"_ICN_"|"_SSN_"|"_DFN_"|"_SPECDATE_"|"_STA5A_"|"_SPEC
. ;W STR
. S RESIEN=0
. ;S CNT=0
. F S RESIEN=$O(^DIZ(99999,IEN,1,SPECIEN,1,RESIEN)) Q:'RESIEN D
. . S RESREC=^DIZ(99999,IEN,1,SPECIEN,1,RESIEN,0)
. . S RESREC1=^DIZ(99999,IEN,1,SPECIEN,1,RESIEN,2)
. . ;S CNT=CNT+1
. . S LOCALLAB=$P(RESREC,U,6),NLTCODE=$P(RESREC,U,2)
. . S NLTNAME=$P(RESREC,U,3),LNNAME=$P(RESREC,U,5)
. . S LNCODE=$P(RESREC,U,4),RESULT=$P(RESREC,U,1)
. . S UNITS=$P(RESREC1,U,1),RANGE=$P(RESREC1,U,2)
. . ; Most of the time High and Low range are separated by a "-"
. . I RANGE["-" D
. . . S LRANGE=$P(RANGE,"-",1),HRANGE=$P(RANGE,"-",2)
. . I RANGE'["-" D
. . . S LRANGE=RANGE,HRANGE=""
. . S LABA="|^"_LOCALLAB_"|"_NLTCODE_"^"_NLTNAME_"|"_LNCODE_"^"_LNNAME_"|"
. . ;
. . S LABB=RESULT_"|"_UNITS_"|"
. . ;
. . S LABC=LRANGE_"|"_HRANGE_"|"
. . W STR_LABA_LABB_LABC,!
Q
;
ERROR(CODE,FAC,MESSAGE) ; Error processing
N ARR,STR
I CODE=1 S STR=DT_": Cannot open output file "_MESSAGE
I CODE=2 S STR=DT_": File name already exists in the output directory "_MESSAGE
I CODE=3 D
. S MESSAGE=$E(MESSAGE,4,5)_"/"_$E(MESSAGE,6,7)_"/"_$E(MESSAGE,2,3)
. S STR=DT_": Trying to process records for Facility #"_FAC_" for the date of "_MESSAGE_" that have already been processed."
S FDA(99999,"+1,",.01)=FAC
S FDA(99999,"+1,",2)=STR
D UPDATE^DIE("","FDA",)
Q
;
;
CULL ; Cull all entries for a facility that have been processed on or before the date in FD x-ref
N A,B,DFN,DELLIEN,FAC,IDATE,IEN,PDATE
S FAC="0"
F S FAC=$O(^DIZ(99999,"FD",FAC)) Q:'FAC D
. S PDATE=0
. F S PDATE=$O(^DIZ(99999,"FD",FAC,PDATE)) Q:'PDATE D
. . S IDATE=0
. . ; Remove entry with FD x-ref
. . S DELLIEN=0
. . S DELLIEN=$O(^DIZ(99999,"FD",FAC,PDATE,DELLIEN))
. . K B
. . S B(99999,DELLIEN_",",.01)="@" D FILE^DIE(,"B")
. . ;
. . F S IDATE=$O(^DIZ(99999,"FDP",FAC,IDATE)) Q:'IDATE!($P(IDATE,".",1)>PDATE) D
. . . S DFN=0
. . . F S DFN=$O(^DIZ(99999,"FDP",FAC,IDATE,DFN)) Q:'DFN D
. . . . S IEN=0
. . . . F S IEN=$O(^DIZ(99999,"FDP",FAC,IDATE,DFN,IEN)) Q:'IEN D
. . . . . K A
. . . . . S A(99999,IEN_",",.01)="@" D FILE^DIE(,"A")
Q
;
;
ERORDSP ; Display errors
;
N DATE,DONE,EDATE,FAC,IEN,PG
S PG=0,DATE=$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)
D HEAD
I '$D(^DIZ(99999,"FDE")) W "No Error's to report." H 4 Q
;
;
S FAC="0"
F S FAC=$O(^DIZ(99999,"FDE",FAC)) Q:'FAC D
. ;
. S EDATE=0
. F S EDATE=$O(^DIZ(99999,"FDE",FAC,EDATE)) Q:'EDATE D
. . S IEN=0
. . F S IEN=$O(^DIZ(99999,"FDE",FAC,EDATE,IEN)) Q:'IEN D
. . . S MSG=^DIZ(99999,IEN,2)
. . . I ($Y+4>IOSL) D PRTC Q:$D(DONE) D HEAD
. . . W !," "_MSG,!
Q
;
HEAD ;
W:$Y>0 @IOF S PG=PG+1
W " "_DATE,?71,"Page ",PG,!!
W " Error log for PBM III national database processing.",!
W " ---------------------------------------------------",!
Q
;
PRTC ;press return to continue prompt
Q:$E(IOST,1,2)'="C-"!($D(IO("S")))
K DIR W ! S DIR(0)="E" D ^DIR K DIR I 'Y S DONE=1
Q
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSULRHL3 6342 printed Sep 23, 2025@20:03:41 Page 2
PSULRHL3 ;HCIOFO/BH - Daily file procesing ; 1/20/11 3:03pm
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**3,18**;MARCH, 2005;Build 7
+2 ;
+3 ; ** THIS ROUTINE SHOULD NEVER BE INSTALLED AT A SITE ***
+4 ; ** THIS ROUTINE IS ONLY TO BE RUN ON THE CMOP-NAT SERVER ***
+5 ;
+6 QUIT
+7 ;
PROCESS ; This process loops through the file containing parsed HL7 data.
+1 ; This process runs each day and collects up to the previous days data.
+2 ; The data is ordered by facility. All the data for the facility for
+3 ; for up to the previous day gets filed into one flat file for PBM to
+4 ; process. A pre-init sub routine CULL loops through all x-refs that
+5 ; indicate processed data for facility and date and culls the data and
+6 ; removes the FD x-ref.
+7 ;
+8 ;
+9 DO CULL
+10 ;
+11 ;
+12 NEW DFN,EDATE,FACILITY,FILE,IEN,OPEN,OUTDIR,PSUDTE,QUIT,RDATE,RC,SDATE,TEMP,X,X1,X2
+13 ;
+14 ; End date for search
+15 DO NOW^%DTC
SET TEMP=%
SET EDATE=$PIECE(TEMP,".",1)
+16 ; Run date i.e. going to process data up to yesterday
+17 SET X1=$PIECE(TEMP,".",1)
SET X2="-1"
DO C^%DTC
SET RDATE=$PIECE(X,".",1)
+18 ;
+19 ;
+20 SET FACILITY=""
SET (QUIT,OPEN)=0
+21 ;
+22 FOR
SET FACILITY=$ORDER(^DIZ(99999,"FDP",FACILITY))
if 'FACILITY!(QUIT)
QUIT
Begin DoDot:1
+23 ;
+24 IF $DATA(^DIZ(99999,"FD",FACILITY,RDATE))
Begin DoDot:2
+25 DO ERROR(3,FACILITY,RDATE)
QUIT
End DoDot:2
QUIT
+26 ; New facility so close any open files.
+27 IF OPEN
DO CLOSE
SET OPEN=0
+28 SET DATE="0"
+29 FOR
SET DATE=$ORDER(^DIZ(99999,"FDP",FACILITY,DATE))
if 'DATE!(DATE'<EDATE)!(QUIT)
QUIT
Begin DoDot:2
+30 ;
+31 SET DFN=""
+32 FOR
SET DFN=$ORDER(^DIZ(99999,"FDP",FACILITY,DATE,DFN))
if 'DFN!(QUIT)
QUIT
Begin DoDot:3
+33 SET IEN=""
+34 FOR
SET IEN=$ORDER(^DIZ(99999,"FDP",FACILITY,DATE,DFN,IEN))
if 'IEN!(QUIT)
QUIT
Begin DoDot:4
+35 IF 'OPEN
Begin DoDot:5
+36 SET RC=$$OPEN()
+37 IF 'RC
SET QUIT=1
QUIT
+38 SET OPEN=1
End DoDot:5
if 'RC
QUIT
+39 DO FILE
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+40 IF OPEN
DO CLOSE
+41 QUIT
+42 ;
+43 ;
OPEN() ; Open the output directory
+1 NEW DST,POP,SRC
+2 SET FILE=FACILITY_DT_".DAT"
+3 ;S OUTDIR="W:\PBM\National-PBM"
+4 SET OUTDIR="USER$:[PBM.LAB]"
+5 ;
+6 KILL DST,SRC
+7 SET SRC(FILE)=""
+8 IF $$LIST^%ZISH(OUTDIR,"SRC","DST")
DO ERROR(2,FACILITY,FILE)
QUIT 0
+9 ;
+10 DO OPEN^%ZISH("HL7FILE",OUTDIR,FILE,"W")
+11 IF $GET(POP)
DO ERROR(1,FACILITY,OUTDIR_FILE)
QUIT 0
+12 ;
+13 QUIT 1
+14 ;
CLOSE ; Set Cross ref indicating that facilities data for the day got
+1 ; processed, and close the output file.
+2 NEW FDA
+3 KILL FDA
+4 SET FDA(99999,"+1,",.01)=$EXTRACT(FILE,1,3)
+5 SET FDA(99999,"+1,",.03)=RDATE
+6 DO UPDATE^DIE("","FDA",)
+7 DO CLOSE^%ZISH("HL7FILE")
+8 QUIT
+9 ;
FILE ; File the lab data to the output file in the following single string format.
+1 ;
+2 ; PSU*4*18 Add use of STA5A
+3 ; PAT|Facility|ICN|SSN|DFN|Date/Time Specimen Collected|STA5A|Site/Specimen|Local Lab Number^Local Lab Name|
+4 ; NLT Code^NLT Name|LOINC Code^LOINC Name|Result|Units|Low Range|High Range|
+5 ;
+6 ;
+7 NEW CNT,CR,DFN,FAC,HRANGE,ICN,LABA,LABB,LABC,LNCODE,LNNAME,LOCALLAB
+8 NEW LRANGE,NLTCODE,NLTNAME,RANGE,REC,RESIEN,RESREC,RESREC1,RESULT,SPEC
+9 NEW SPECDATE,SPECREC,SPECIEN,SSN,STR,STR1,TEST,UNITS,STA5A
+10 ;
+11 USE IO
+12 SET REC=^DIZ(99999,IEN,0)
+13 SET SSN=$PIECE(REC,U,5)
SET ICN=$PIECE(REC,U,4)
SET FAC=$PIECE(REC,U,1)
SET DFN=$PIECE(REC,U,2)
SET STA5A=$PIECE(REC,U,6)
+14 ;
+15 SET SPECIEN=0
+16 FOR
SET SPECIEN=$ORDER(^DIZ(99999,IEN,1,SPECIEN))
if 'SPECIEN
QUIT
Begin DoDot:1
+17 ; Do not file if Specimen has no results
+18 SET TEST=0
+19 SET TEST=$ORDER(^DIZ(99999,IEN,1,SPECIEN,1,TEST))
if 'TEST
QUIT
+20 SET SPECREC=^DIZ(99999,IEN,1,SPECIEN,0)
+21 SET SPEC=$PIECE(SPECREC,U,1)
SET SPECDATE=$PIECE(SPECREC,U,2)
+22 SET STR="PAT|"_FAC_"|"_ICN_"|"_SSN_"|"_DFN_"|"_SPECDATE_"|"_STA5A_"|"_SPEC
+23 ;W STR
+24 SET RESIEN=0
+25 ;S CNT=0
+26 FOR
SET RESIEN=$ORDER(^DIZ(99999,IEN,1,SPECIEN,1,RESIEN))
if 'RESIEN
QUIT
Begin DoDot:2
+27 SET RESREC=^DIZ(99999,IEN,1,SPECIEN,1,RESIEN,0)
+28 SET RESREC1=^DIZ(99999,IEN,1,SPECIEN,1,RESIEN,2)
+29 ;S CNT=CNT+1
+30 SET LOCALLAB=$PIECE(RESREC,U,6)
SET NLTCODE=$PIECE(RESREC,U,2)
+31 SET NLTNAME=$PIECE(RESREC,U,3)
SET LNNAME=$PIECE(RESREC,U,5)
+32 SET LNCODE=$PIECE(RESREC,U,4)
SET RESULT=$PIECE(RESREC,U,1)
+33 SET UNITS=$PIECE(RESREC1,U,1)
SET RANGE=$PIECE(RESREC1,U,2)
+34 ; Most of the time High and Low range are separated by a "-"
+35 IF RANGE["-"
Begin DoDot:3
+36 SET LRANGE=$PIECE(RANGE,"-",1)
SET HRANGE=$PIECE(RANGE,"-",2)
End DoDot:3
+37 IF RANGE'["-"
Begin DoDot:3
+38 SET LRANGE=RANGE
SET HRANGE=""
End DoDot:3
+39 SET LABA="|^"_LOCALLAB_"|"_NLTCODE_"^"_NLTNAME_"|"_LNCODE_"^"_LNNAME_"|"
+40 ;
+41 SET LABB=RESULT_"|"_UNITS_"|"
+42 ;
+43 SET LABC=LRANGE_"|"_HRANGE_"|"
+44 WRITE STR_LABA_LABB_LABC,!
End DoDot:2
End DoDot:1
+45 QUIT
+46 ;
ERROR(CODE,FAC,MESSAGE) ; Error processing
+1 NEW ARR,STR
+2 IF CODE=1
SET STR=DT_": Cannot open output file "_MESSAGE
+3 IF CODE=2
SET STR=DT_": File name already exists in the output directory "_MESSAGE
+4 IF CODE=3
Begin DoDot:1
+5 SET MESSAGE=$EXTRACT(MESSAGE,4,5)_"/"_$EXTRACT(MESSAGE,6,7)_"/"_$EXTRACT(MESSAGE,2,3)
+6 SET STR=DT_": Trying to process records for Facility #"_FAC_" for the date of "_MESSAGE_" that have already been processed."
End DoDot:1
+7 SET FDA(99999,"+1,",.01)=FAC
+8 SET FDA(99999,"+1,",2)=STR
+9 DO UPDATE^DIE("","FDA",)
+10 QUIT
+11 ;
+12 ;
CULL ; Cull all entries for a facility that have been processed on or before the date in FD x-ref
+1 NEW A,B,DFN,DELLIEN,FAC,IDATE,IEN,PDATE
+2 SET FAC="0"
+3 FOR
SET FAC=$ORDER(^DIZ(99999,"FD",FAC))
if 'FAC
QUIT
Begin DoDot:1
+4 SET PDATE=0
+5 FOR
SET PDATE=$ORDER(^DIZ(99999,"FD",FAC,PDATE))
if 'PDATE
QUIT
Begin DoDot:2
+6 SET IDATE=0
+7 ; Remove entry with FD x-ref
+8 SET DELLIEN=0
+9 SET DELLIEN=$ORDER(^DIZ(99999,"FD",FAC,PDATE,DELLIEN))
+10 KILL B
+11 SET B(99999,DELLIEN_",",.01)="@"
DO FILE^DIE(,"B")
+12 ;
+13 FOR
SET IDATE=$ORDER(^DIZ(99999,"FDP",FAC,IDATE))
if 'IDATE!($PIECE(IDATE,".",1)>PDATE)
QUIT
Begin DoDot:3
+14 SET DFN=0
+15 FOR
SET DFN=$ORDER(^DIZ(99999,"FDP",FAC,IDATE,DFN))
if 'DFN
QUIT
Begin DoDot:4
+16 SET IEN=0
+17 FOR
SET IEN=$ORDER(^DIZ(99999,"FDP",FAC,IDATE,DFN,IEN))
if 'IEN
QUIT
Begin DoDot:5
+18 KILL A
+19 SET A(99999,IEN_",",.01)="@"
DO FILE^DIE(,"A")
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+20 QUIT
+21 ;
+22 ;
ERORDSP ; Display errors
+1 ;
+2 NEW DATE,DONE,EDATE,FAC,IEN,PG
+3 SET PG=0
SET DATE=$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)
+4 DO HEAD
+5 IF '$DATA(^DIZ(99999,"FDE"))
WRITE "No Error's to report."
HANG 4
QUIT
+6 ;
+7 ;
+8 SET FAC="0"
+9 FOR
SET FAC=$ORDER(^DIZ(99999,"FDE",FAC))
if 'FAC
QUIT
Begin DoDot:1
+10 ;
+11 SET EDATE=0
+12 FOR
SET EDATE=$ORDER(^DIZ(99999,"FDE",FAC,EDATE))
if 'EDATE
QUIT
Begin DoDot:2
+13 SET IEN=0
+14 FOR
SET IEN=$ORDER(^DIZ(99999,"FDE",FAC,EDATE,IEN))
if 'IEN
QUIT
Begin DoDot:3
+15 SET MSG=^DIZ(99999,IEN,2)
+16 IF ($Y+4>IOSL)
DO PRTC
if $DATA(DONE)
QUIT
DO HEAD
+17 WRITE !," "_MSG,!
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
HEAD ;
+1 if $Y>0
WRITE @IOF
SET PG=PG+1
+2 WRITE " "_DATE,?71,"Page ",PG,!!
+3 WRITE " Error log for PBM III national database processing.",!
+4 WRITE " ---------------------------------------------------",!
+5 QUIT
+6 ;
PRTC ;press return to continue prompt
+1 if $EXTRACT(IOST,1,2)'="C-"!($DATA(IO("S")))
QUIT
+2 KILL DIR
WRITE !
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET DONE=1
+3 QUIT
+4 ;
+5 ;
