- ECXPLBB ;DALOI/KML - DSS BLOOD BANK PRE-EXTRACT AUDIT REPORT ;5/31/17 16:32
- ;;3.0;DSS EXTRACTS;**78,92,105,136,143,149,153,156,166**;Dec 22, 1997;Build 24
- ;Per VA Directive 6402, this routine should not be modified. Medical Device # BK970021
- ;entry point from option
- D SETUP^ECXLBB1 I ECFILE="" Q ;149
- N ECXINST,ECXPORT,CNT ;149
- D DATES
- Q:ECED']""!(ECSD']"") ;149 Changed logic so it stops if either start or stop date is null
- S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I $G(ECXPORT) D Q ;149 Section added
- .W !!,"This report may take a while to generate. Please be patient.",!
- .S ECSDN=$$FMTE^XLFDT(ECSD),ECEDN=$$FMTE^XLFDT(ECED),ECSD1=ECSD-.1
- .K ^TMP($J,"ECXPORT")
- .S ^TMP($J,"ECXPORT",0)="NAME^SSN^FEEDER LOCATION^TRANSFUSION DATE^COMPONENT^NUMBER OF UNITS",CNT=1
- .D START
- .D EXPDISP^ECXUTL1
- .D ^ECXKILL
- N ECXPOP S ECXPOP=0 D QUE Q:ECXPOP
- ;
- START ; entry point from tasked job
- ; get LAB DATA and build temporary global ^TMP("ECXLBB",$J)
- N ECTRSP,ECADMT,ECTODT,ECXRPT,ECOUT,ECXSTR,ECRDT,ECLINE,ECPG,ECQUIT
- N ECD,ECXDFN,ECARRY,EC66,ECERR,ECTRFDT,ECTRFTM,ECX,ECINOUT,ECXJOB
- N ECXLOGIC,ECXREC ;156
- S ECXJOB=$J
- K ^TMP("ECXLBB",ECXJOB)
- U IO
- I '$G(ECXPORT) I $E(IOST,1,2)="C-" W !,"Retrieving records... " ;149
- S ECXRPT=1 D AUDRPT^ECXLBB1 ;149
- OUTPUT ; entry point called by EN tag
- I '$D(^TMP("ECXLBB",ECXJOB)) W:'$G(ECXPORT) !,"There were no records that met the date range criteria" Q ;149
- S (ECPG,ECDATE,ECQUIT,ECXDFN,ECXREC)=0,ECLINE="",$P(ECLINE,"=",80)="="
- S ECSDN=$$FMTE^XLFDT(ECSD,9),ECEDN=$$FMTE^XLFDT(ECED,9),ECRDT=$$FMTE^XLFDT(DT,9)
- I '$G(ECXPORT) W:$E(IOST,1,2)="C-" @IOF D HED ;149
- F S ECXDFN=$O(^TMP("ECXLBB",ECXJOB,ECXDFN)) Q:'ECXDFN D Q:ECQUIT
- .F S ECDATE=$O(^TMP("ECXLBB",ECXJOB,ECXDFN,ECDATE)) Q:'ECDATE D Q:ECQUIT
- ..F S ECXREC=$O(^TMP("ECXLBB",ECXJOB,ECXDFN,ECDATE,ECXREC)) Q:'+ECXREC S ECXSTR=^(ECXREC) D PRINT Q:ECQUIT ;143,156-added additional for loop
- I '$G(ECXPORT) D ^ECXKILL ;149
- Q
- ;
- PRINT ;
- I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=$P(ECXSTR,U,5)_U_$P(ECXSTR,U,4)_U_$P(ECXSTR,U,16)_U_$$FMTE^XLFDT($$HL7TFM^XLFDT($P(ECXSTR,U,8)),2)_U_$P(ECXSTR,U,11)_U_+$P(ECXSTR,U,12),CNT=CNT+1 Q ;149
- I $Y+5>IOSL D Q:ECQUIT
- . I $E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR K DIR I 'Y S ECQUIT=1 Q
- . W @IOF D HED
- W !,$P(ECXSTR,"^",5),?11,$P(ECXSTR,"^",4),?26,$P(ECXSTR,"^",16)
- W ?37,$$FMTE^XLFDT($$HL7TFM^XLFDT($P(ECXSTR,"^",8)),2)
- W ?49,$P(ECXSTR,"^",11),?60,$J(+$P(ECXSTR,"^",12),2)
- Q
- ;
- HED ;
- S ECPG=ECPG+1
- W !,"Laboratory Blood Bank (LBB) Pre-Extract Audit Report",?72,"Page",$J(ECPG,3) ;136,166 tjl - Changed report title
- W !,ECSDN," - ",ECEDN,?58,"Run Date:",$J(ECRDT,12)
- W !,?37,"Transf",?57,"Number"
- W !,"Name",?14,"SSN",?25,"FDR LOC",?37,"Date",?49,"COMP"
- W ?57,"of Units"
- W !,ECLINE
- Q
- DATES ;
- N OUT,CHKFLG
- I '$D(ECNODE) S ECNODE=7
- I '$D(ECHEAD) S ECHEAD=" "
- W @IOF,!,"Laboratory Blood Bank (LBB) Pre-Extract Audit Report Information for DSS",!! ;136,166 tjl - Changed report title
- ;Added descriptive text DSS FY13 Logic
- W !,"**NOTE: This audit can only be run prior to the LBB Extract being generated." ;136
- W !,"If you have already generated your LBB Extract, refer to the Processing "
- W !,"Guide Chapter 4 section on Regenerating.**",!
- S:'$D(ECINST) ECINST=+$P(^ECX(728,1,0),U)
- S ECXINST=ECINST
- K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
- D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
- S ECLDT=$S($D(^ECX(728,1,ECNODE)):$P(^(ECNODE),U,ECPIECE),1:2610624)
- S:ECLDT="" ECLDT=2610624
- S ECOUT=0 F S (ECED,ECSD)="" D Q:ECOUT
- . K %DT S %DT="AEX",%DT("A")="Starting with Date: " D ^%DT
- . I Y<0 S ECOUT=1 Q
- . S ECSD=Y
- . K %DT S %DT="AEX",%DT("A")="Ending with Date: " D ^%DT
- . I Y<0 S ECOUT=1 Q
- . I Y<ECSD W !!,"The ending date cannot be earlier than the starting date.",!,"Please try again.",!! Q
- . I $E(Y,1,5)'=$E(ECSD,1,5) W !!,"Beginning and ending dates must be in the same month and year.",!,"Please try again.",!! Q
- . S ECED=Y
- . I ECLDT'<ECSD W !!,"The Blood Bank information has already been extracted through ",$$FMTE^XLFDT(ECLDT),".",!,"Please enter a new date range.",!! Q
- . S ECOUT=1
- Q
- ;
- QUE ;
- K ZTSAVE
- S ECSDN=$$FMTE^XLFDT(ECSD),ECEDN=$$FMTE^XLFDT(ECED),ECSD1=ECSD-.1
- K ZTSAVE
- F X="ECINST","ECED","ECSD","ECSD1","ECEDN","ECSDN" S ZTSAVE(X)=""
- F X="ECPACK","ECPIECE","ECRTN","ECGRP","ECNODE" S ZTSAVE(X)=""
- F X="ECFILE","ECHEAD","ECVER","ECINST","ECXINST" S ZTSAVE(X)=""
- F X="ECXLOGIC","ECXDATES" S ZTSAVE(X)=""
- S ZTDESC=ECPACK_" EXTRACT AUDIT REPORT: "_ECSDN_" TO "_ECEDN,ZTRTN="START^ECXPLBB",ZTIO="" ;149,153
- S IOP="Q" W ! S %ZIS="QMP" D ^%ZIS S:POP ECXPOP=1 Q:POP I $D(IO("Q")) K IO("Q"),ZTIO D ^%ZTLOAD W:$D(ZTSK) !,$C(7),"REQUEST QUEUED",!,"Task #: ",$G(ZTSK) K I,ZTSK,ZTIO,ZTSAVE,ZTRTN D HOME^%ZIS S ECXPOP=1
- Q
- ;
- EN(ECXJOB,ECSD,ECED) ; entry point used primarily for testing
- ; input:
- ; ECXJOB = $J that is assigned to the 2nd subscript of
- ; the temporary global array containing the
- ; extracted data that feeds the pre-extract
- ; audit report
- ; ECSD = starting date range representing the FM
- ; date used to retrieve data from file #63
- ; ECED = ending date range representing the FM date
- ; used to retrieve data from file #63
- ; syntax of the call: D EN^ECXPLBB(541571372,3000101,3000131)
- D OUTPUT
- Q
- ;
- ;ECXPLBB
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXPLBB 5520 printed Feb 18, 2025@23:19:53 Page 2
- ECXPLBB ;DALOI/KML - DSS BLOOD BANK PRE-EXTRACT AUDIT REPORT ;5/31/17 16:32
- +1 ;;3.0;DSS EXTRACTS;**78,92,105,136,143,149,153,156,166**;Dec 22, 1997;Build 24
- +2 ;Per VA Directive 6402, this routine should not be modified. Medical Device # BK970021
- +3 ;entry point from option
- +4 ;149
- DO SETUP^ECXLBB1
- IF ECFILE=""
- QUIT
- +5 ;149
- NEW ECXINST,ECXPORT,CNT
- +6 DO DATES
- +7 ;149 Changed logic so it stops if either start or stop date is null
- if ECED']""!(ECSD']"")
- QUIT
- +8 ;149 Section added
- SET ECXPORT=$$EXPORT^ECXUTL1
- if ECXPORT=-1
- QUIT
- IF $GET(ECXPORT)
- Begin DoDot:1
- +9 WRITE !!,"This report may take a while to generate. Please be patient.",!
- +10 SET ECSDN=$$FMTE^XLFDT(ECSD)
- SET ECEDN=$$FMTE^XLFDT(ECED)
- SET ECSD1=ECSD-.1
- +11 KILL ^TMP($JOB,"ECXPORT")
- +12 SET ^TMP($JOB,"ECXPORT",0)="NAME^SSN^FEEDER LOCATION^TRANSFUSION DATE^COMPONENT^NUMBER OF UNITS"
- SET CNT=1
- +13 DO START
- +14 DO EXPDISP^ECXUTL1
- +15 DO ^ECXKILL
- End DoDot:1
- QUIT
- +16 NEW ECXPOP
- SET ECXPOP=0
- DO QUE
- if ECXPOP
- QUIT
- +17 ;
- START ; entry point from tasked job
- +1 ; get LAB DATA and build temporary global ^TMP("ECXLBB",$J)
- +2 NEW ECTRSP,ECADMT,ECTODT,ECXRPT,ECOUT,ECXSTR,ECRDT,ECLINE,ECPG,ECQUIT
- +3 NEW ECD,ECXDFN,ECARRY,EC66,ECERR,ECTRFDT,ECTRFTM,ECX,ECINOUT,ECXJOB
- +4 ;156
- NEW ECXLOGIC,ECXREC
- +5 SET ECXJOB=$JOB
- +6 KILL ^TMP("ECXLBB",ECXJOB)
- +7 USE IO
- +8 ;149
- IF '$GET(ECXPORT)
- IF $EXTRACT(IOST,1,2)="C-"
- WRITE !,"Retrieving records... "
- +9 ;149
- SET ECXRPT=1
- DO AUDRPT^ECXLBB1
- OUTPUT ; entry point called by EN tag
- +1 ;149
- IF '$DATA(^TMP("ECXLBB",ECXJOB))
- if '$GET(ECXPORT)
- WRITE !,"There were no records that met the date range criteria"
- QUIT
- +2 SET (ECPG,ECDATE,ECQUIT,ECXDFN,ECXREC)=0
- SET ECLINE=""
- SET $PIECE(ECLINE,"=",80)="="
- +3 SET ECSDN=$$FMTE^XLFDT(ECSD,9)
- SET ECEDN=$$FMTE^XLFDT(ECED,9)
- SET ECRDT=$$FMTE^XLFDT(DT,9)
- +4 ;149
- IF '$GET(ECXPORT)
- if $EXTRACT(IOST,1,2)="C-"
- WRITE @IOF
- DO HED
- +5 FOR
- SET ECXDFN=$ORDER(^TMP("ECXLBB",ECXJOB,ECXDFN))
- if 'ECXDFN
- QUIT
- Begin DoDot:1
- +6 FOR
- SET ECDATE=$ORDER(^TMP("ECXLBB",ECXJOB,ECXDFN,ECDATE))
- if 'ECDATE
- QUIT
- Begin DoDot:2
- +7 ;143,156-added additional for loop
- FOR
- SET ECXREC=$ORDER(^TMP("ECXLBB",ECXJOB,ECXDFN,ECDATE,ECXREC))
- if '+ECXREC
- QUIT
- SET ECXSTR=^(ECXREC)
- DO PRINT
- if ECQUIT
- QUIT
- End DoDot:2
- if ECQUIT
- QUIT
- End DoDot:1
- if ECQUIT
- QUIT
- +8 ;149
- IF '$GET(ECXPORT)
- DO ^ECXKILL
- +9 QUIT
- +10 ;
- PRINT ;
- +1 ;149
- IF $GET(ECXPORT)
- SET ^TMP($JOB,"ECXPORT",CNT)=$PIECE(ECXSTR,U,5)_U_$PIECE(ECXSTR,U,4)_U_$PIECE(ECXSTR,U,16)_U_$$FMTE^XLFDT($$HL7TFM^XLFDT($PIECE(ECXSTR,U,8)),2)_U_$PIECE(ECXSTR,U,11)_U_+$PIECE(ECXSTR,U,12)
- SET CNT=CNT+1
- QUIT
- +2 IF $Y+5>IOSL
- Begin DoDot:1
- +3 IF $EXTRACT(IOST,1,2)["C-"
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- IF 'Y
- SET ECQUIT=1
- QUIT
- +4 WRITE @IOF
- DO HED
- End DoDot:1
- if ECQUIT
- QUIT
- +5 WRITE !,$PIECE(ECXSTR,"^",5),?11,$PIECE(ECXSTR,"^",4),?26,$PIECE(ECXSTR,"^",16)
- +6 WRITE ?37,$$FMTE^XLFDT($$HL7TFM^XLFDT($PIECE(ECXSTR,"^",8)),2)
- +7 WRITE ?49,$PIECE(ECXSTR,"^",11),?60,$JUSTIFY(+$PIECE(ECXSTR,"^",12),2)
- +8 QUIT
- +9 ;
- HED ;
- +1 SET ECPG=ECPG+1
- +2 ;136,166 tjl - Changed report title
- WRITE !,"Laboratory Blood Bank (LBB) Pre-Extract Audit Report",?72,"Page",$JUSTIFY(ECPG,3)
- +3 WRITE !,ECSDN," - ",ECEDN,?58,"Run Date:",$JUSTIFY(ECRDT,12)
- +4 WRITE !,?37,"Transf",?57,"Number"
- +5 WRITE !,"Name",?14,"SSN",?25,"FDR LOC",?37,"Date",?49,"COMP"
- +6 WRITE ?57,"of Units"
- +7 WRITE !,ECLINE
- +8 QUIT
- DATES ;
- +1 NEW OUT,CHKFLG
- +2 IF '$DATA(ECNODE)
- SET ECNODE=7
- +3 IF '$DATA(ECHEAD)
- SET ECHEAD=" "
- +4 ;136,166 tjl - Changed report title
- WRITE @IOF,!,"Laboratory Blood Bank (LBB) Pre-Extract Audit Report Information for DSS",!!
- +5 ;Added descriptive text DSS FY13 Logic
- +6 ;136
- WRITE !,"**NOTE: This audit can only be run prior to the LBB Extract being generated."
- +7 WRITE !,"If you have already generated your LBB Extract, refer to the Processing "
- +8 WRITE !,"Guide Chapter 4 section on Regenerating.**",!
- +9 if '$DATA(ECINST)
- SET ECINST=+$PIECE(^ECX(728,1,0),U)
- +10 SET ECXINST=ECINST
- +11 KILL ECXDIC
- SET DA=ECINST
- SET DIC="^DIC(4,"
- SET DIQ(0)="I"
- SET DIQ="ECXDIC"
- SET DR=".01;99"
- +12 DO EN^DIQ1
- SET ECINST=$GET(ECXDIC(4,DA,99,"I"))
- KILL DIC,DIQ,DA,DR,ECXDIC
- +13 SET ECLDT=$SELECT($DATA(^ECX(728,1,ECNODE)):$PIECE(^(ECNODE),U,ECPIECE),1:2610624)
- +14 if ECLDT=""
- SET ECLDT=2610624
- +15 SET ECOUT=0
- FOR
- SET (ECED,ECSD)=""
- Begin DoDot:1
- +16 KILL %DT
- SET %DT="AEX"
- SET %DT("A")="Starting with Date: "
- DO ^%DT
- +17 IF Y<0
- SET ECOUT=1
- QUIT
- +18 SET ECSD=Y
- +19 KILL %DT
- SET %DT="AEX"
- SET %DT("A")="Ending with Date: "
- DO ^%DT
- +20 IF Y<0
- SET ECOUT=1
- QUIT
- +21 IF Y<ECSD
- WRITE !!,"The ending date cannot be earlier than the starting date.",!,"Please try again.",!!
- QUIT
- +22 IF $EXTRACT(Y,1,5)'=$EXTRACT(ECSD,1,5)
- WRITE !!,"Beginning and ending dates must be in the same month and year.",!,"Please try again.",!!
- QUIT
- +23 SET ECED=Y
- +24 IF ECLDT'<ECSD
- WRITE !!,"The Blood Bank information has already been extracted through ",$$FMTE^XLFDT(ECLDT),".",!,"Please enter a new date range.",!!
- QUIT
- +25 SET ECOUT=1
- End DoDot:1
- if ECOUT
- QUIT
- +26 QUIT
- +27 ;
- QUE ;
- +1 KILL ZTSAVE
- +2 SET ECSDN=$$FMTE^XLFDT(ECSD)
- SET ECEDN=$$FMTE^XLFDT(ECED)
- SET ECSD1=ECSD-.1
- +3 KILL ZTSAVE
- +4 FOR X="ECINST","ECED","ECSD","ECSD1","ECEDN","ECSDN"
- SET ZTSAVE(X)=""
- +5 FOR X="ECPACK","ECPIECE","ECRTN","ECGRP","ECNODE"
- SET ZTSAVE(X)=""
- +6 FOR X="ECFILE","ECHEAD","ECVER","ECINST","ECXINST"
- SET ZTSAVE(X)=""
- +7 FOR X="ECXLOGIC","ECXDATES"
- SET ZTSAVE(X)=""
- +8 ;149,153
- SET ZTDESC=ECPACK_" EXTRACT AUDIT REPORT: "_ECSDN_" TO "_ECEDN
- SET ZTRTN="START^ECXPLBB"
- SET ZTIO=""
- +9 SET IOP="Q"
- WRITE !
- SET %ZIS="QMP"
- DO ^%ZIS
- if POP
- SET ECXPOP=1
- if POP
- QUIT
- IF $DATA(IO("Q"))
- KILL IO("Q"),ZTIO
- DO ^%ZTLOAD
- if $DATA(ZTSK)
- WRITE !,$CHAR(7),"REQUEST QUEUED",!,"Task #: ",$GET(ZTSK)
- KILL I,ZTSK,ZTIO,ZTSAVE,ZTRTN
- DO HOME^%ZIS
- SET ECXPOP=1
- +10 QUIT
- +11 ;
- EN(ECXJOB,ECSD,ECED) ; entry point used primarily for testing
- +1 ; input:
- +2 ; ECXJOB = $J that is assigned to the 2nd subscript of
- +3 ; the temporary global array containing the
- +4 ; extracted data that feeds the pre-extract
- +5 ; audit report
- +6 ; ECSD = starting date range representing the FM
- +7 ; date used to retrieve data from file #63
- +8 ; ECED = ending date range representing the FM date
- +9 ; used to retrieve data from file #63
- +10 ; syntax of the call: D EN^ECXPLBB(541571372,3000101,3000131)
- +11 DO OUTPUT
- +12 QUIT
- +13 ;
- +14 ;ECXPLBB
