BWMPEXP ;IHS/CIA/PLS - Mammography Project Export ;01-Oct-2003 16:55;PLS
;;2.0;WOMEN'S HEALTH;**9**;16-Apr-2003 13:01
;=================================================================
EN ;
N Y,BWBEGDT,BWENDDT,BWPOP,BWSTYLE,BWPATH,BWFILE,BWSPN
N PCNT
S BWSTYLE=""
D TITLE^BWUTL5("Export Mammography Project Data")
D ASK
Q:BWPOP
S BWPATH=$P($G(^BWSITE($G(DUZ(2)),0)),U,14)
S BWFILE=$P($G(^BWSITE($G(DUZ(2)),0)),U,13)_"mp"_$$DATE_"."_$S(BWSTYLE="X":"xml",1:"txt")
S BWPOP=$$OPEN^%ZISH(BWPATH,BWFILE,"W")
I 'BWPOP D
.D CLOSE^%ZISH()
E D
.D HFSERR S BWPOP=1
I 'BWPOP D
.W !!,"Working... "
.D LOOP(44,BWBEGDT,BWENDDT,BWSTYLE="X") ; 44=Mammography Project Procedure Type
.S Y=$$GTF^%ZISH($NA(^TMP($J,"BWMP",1)),3,BWPATH,BWFILE)
.I Y D
..W !!,"Number of Procedures exported: "_+$G(PCNT)
..W !!,"The export data has been successfully saved."
..W !,"The '"_BWFILE_"' file was saved in the '"_BWPATH_"' folder."
E D
.D HFSERR S BWPOP=1
Q
; Collect report qualifiers
ASK ;
N DIRUT,DIR
D DATEINFO
D ASKDATES^BWUTL3(.BWBEGDT,.BWENDDT,.BWPOP)
I 'BWPOP D
.K DIR
.S DIR(0)="S^F:Fixed Length Fields;X:XML"
.S DIR("A")="Which Style"
.D ^DIR
.I $D(DIRUT) S BWPOP=1
.E S BWSTYLE=Y
Q
LOOP(BWPTYP,BWBEGDT,BWENDDT,XML) ;
N BWDT,BWIEN,BWMPARY,CNT,BWENDT,BW0
; Build array of active fields
K ^TMP($J,"BWMP")
D BLDARY(.BWMPARY)
S XML=$G(XML,0)
I XML D
.D ADD("<?xml version=""1.0"" encoding=""utf-8"" ?>")
.D ADD("<Procedures>")
.D ADD("<ExportDateRange>"_$$FMTE^XLFDT(BWBEGDT)_" to "_$$FMTE^XLFDT(BWENDDT)_"</ExportDateRange>")
S BWDT=BWBEGDT-.00001,BWENDT=BWENDDT+.99999
F S BWDT=$O(^BWPCD("D",BWDT)) Q:'BWDT!(BWDT>BWENDT) D
.S BWIEN=0
.F S BWIEN=$O(^BWPCD("D",BWDT,BWIEN)) Q:'BWIEN D
..I '$D(^BWPCD(BWIEN,0)) K ^BWPCD("D",BWDT,BWIEN)
..S BW0=$G(^BWPCD(BWIEN,0))
..Q:$P($G(^BWPCD(BWIEN,0)),U,4)'=BWPTYP
..D PROC(BWIEN,XML)
D:XML ADD("</Procedures>")
Q
; Loop thru the field array for a given procedure ien
; Input: IEN - Procedure IEN
; XML - Flag indicating output style
; 0 - fixed length string per record
; 1 - XML record format
PROC(IEN,XML) ;
N BWMMP,LBLNM,OUT,COL,LEN,BWMMP0
S BWMMP=0
;I $$WORKING(.BWSPN)
S PCNT=+$G(PCNT)+1
I 'XML D
.F S BWMMP=$O(BWMPARY(BWMMP)) Q:'BWMMP D
..;D ADD($$LBLNM(BWMPARY(BWMMP))_" = "_$$DATA(IEN,(BWMPARY(BWMMP))))
..S BWMMP0=$G(^BWMPEXP(BWMPARY(BWMMP),0))
..S COL=$P($P(BWMMP0,U,2),","),LEN=$P($P(BWMMP0,U,2),",",2)
..S $E(OUT,COL,COL+LEN)=$$DATA(IEN,BWMPARY(BWMMP))
.D ADD(OUT)
E D
.D ADD(" <Procedure>")
.F S BWMMP=$O(BWMPARY(BWMMP)) Q:'BWMMP D
..S LBLNM=$$LBLNM(BWMPARY(BWMMP),1)
..D ADD(" <"_LBLNM_">"_$$DATA(IEN,(BWMPARY(BWMMP)))_"</"_LBLNM_">")
.D ADD(" </Procedure>")
Q
DATA(PIEN,BWMMP) ;
N BWMMP0,FILE,FLD,FMT,VAL,FMTJ,FMTJ1,PAD,FMTD
N EXT,PGM
S BWMMP0=$G(^BWMPEXP(BWMMP,0))
S FILE=$P($P(BWMMP0,U,4),",")
S FLD=$P($P(BWMMP0,U,4),",",2)
S LEN=$P($P(BWMMP0,U,2),",",2)
S FMT=$P(BWMMP0,U,5)
S VAL=""
S VAL=$$GET1^DIQ(FILE,PIEN,FLD,$S(FMT["I":"I",1:"E"))
I $F(FMT,"Z")>0 D
.X:$L($G(^BWMPEXP(BWMMP,1))) ^BWMPEXP(BWMMP,1)
I $F(FMT,"J")>0 D
.S FMTJ=$F(FMT,"J"),FMTJ=$E(FMT,FMTJ,FMTJ+1),FMTJ1=$E(FMTJ,1)
.S PAD=$E(FMTJ,2)
.S PGM="VAL="_$S(FMTJ1="C":"$$CJ^XLFSTR(VAL,LEN,PAD)",FMTJ1="R":"$$RJ^XLFSTR(VAL,LEN,PAD)",FMTJ1="L":"$$LJ^XLFSTR(VAL,LEN,PAD)",1:"")
.S:$L(PGM)>4 @PGM
; Check for Date format
I $F(FMT,"D")>0 D
.S FMTD=$E(FMT,$F(FMT,"D"))
.S VAL=$TR($$FMTE^XLFDT(VAL,$S(FMTD=2:"7",1:"5")_"Z"),"/","")
.S:FMTD=3 VAL=$E(VAL,1,2)_$E(VAL,5,8)
Q $E(VAL,1,LEN)
; Return array containing active export fields
BLDARY(ARY) ;
N IEN,ORDN
S IEN=0
F S IEN=$O(^BWMPEXP(IEN)) Q:'IEN D
.S ORDN=+$P($G(^BWMPEXP(IEN,0)),U,3)
.S:ORDN>0 ARY(ORDN)=IEN
Q
; Return label name for data field
; Input: BWMMP - IEN of BW MAMMOGRAPHY EXPORT DEFINITIONS (9002086.26)
; STRIP - 0: do nothing, 1: strip spaces
LBLNM(BWMMP,STRIP) ;
N LBLNAME
S STRIP=$G(STRIP,0)
S LBLNAME=$$GET1^DIQ(9002086.26,BWMMP,.06,"E")
S:LBLNAME="" LBLNAME=$$GET1^DIQ(9002086.26,BWMMP,.01,"E")
Q $S(STRIP:$$STRIP(LBLNAME),1:LBLNAME)
; Return flag indicating given race is defined for patient
; Input: PIEN - Procedure IEN
; RIEN - IEN to BW RACE File (9002086.34) or array of iens
RACE(PIEN,RIEN) ;
N RARY,FLG,LP,RACE,I,BWDFN,PRIEN
S BWDFN=+$P($G(^BWPCD(PIEN,0)),U,2)
Q:'BWDFN 0
S I=0 F S I=$O(^BWP(BWDFN,2,I)) Q:'I D
.; Build array with patient's race iens
.S PRIEN=+$G(^BWP(BWDFN,2,I,0))
.S:PRIEN RARY(PRIEN)=""
S:$D(RIEN)#2 RIEN(-1)=RIEN
S FLG=0,RACE="" F S RACE=$O(RIEN(RACE)) Q:RACE=""!FLG D
.S:$D(RARY(RIEN(RACE)))>0 FLG=1
Q FLG
; Return CDC coded values for Ethinicity
; (1=Hispanic,2=Not Hispanic,3=Unknown or Declined to answer)
ETHNIC(PIEN) ;
N BWDFN
S BWDFN=+$P($G(^BWPCD(PIEN,0)),U,2)
Q:'BWDFN 3
Q $$HISPANIC^BWMDEX2
; Add a node to the global
ADD(VAL) ;
S CNT=+$G(CNT)+1
S ^TMP($J,"BWMP",CNT)=VAL
Q
; Strip out illegal characters for XML output
STRIP(X) ;
S X=$$STRIP^XLFSTR(X,"#/ <>()")
Q X
; Format current date as YYYYMMDD
DATE() ;
Q $TR($$FMTE^XLFDT($$DT^XLFDT,"7Z"),"/","")
;
DATEINFO ;
W !?3,"Select date range to export."
Q
; Displays spinning icon to indicate progress
; Input: BWAST - Start character position
; BWAP - Suppress printing
; BWAS - List of characters to print
WORKING(BWAST,BWAP,BWAS) ;
Q 1
;Q:'$D(IO(0))!$D(ZTQUEUED) 0
;N BWAZ
;S BWAZ(0)=$I,BWAS=$G(BWAS,"|/-\"),BWAST=+$G(BWAST)
;S BWAST=$S(BWAST<0:0,1:BWAST#$L(BWAS)+1)
;U IO(0)
;W:'$G(BWAP) *8,*$S(BWAST:$A(BWAS,BWAST),1:32)
;R BWAZ#1:0 S BWAZ=$C(BWAZ)
;U BWAZ(0)
;Q BWAZ=94
;
; Display Host File Message
HFSERR ;
W !!?5,"* Save to Host File Server FAILED. Contact your sitemanager."
D DIRZ^BWUTLP
Q
BWMPEXP ;IHS/CIA/PLS - Mammography Project Export ;01-Oct-2003 16:55;PLS
+1 ;;2.0;WOMEN'S HEALTH;**9**;16-Apr-2003 13:01
+2 ;=================================================================
EN ;
+1 NEW Y,BWBEGDT,BWENDDT,BWPOP,BWSTYLE,BWPATH,BWFILE,BWSPN
+2 NEW PCNT
+3 SET BWSTYLE=""
+4 DO TITLE^BWUTL5("Export Mammography Project Data")
+5 DO ASK
+6 IF BWPOP
QUIT
+7 SET BWPATH=$PIECE($GET(^BWSITE($GET(DUZ(2)),0)),U,14)
+8 SET BWFILE=$PIECE($GET(^BWSITE($GET(DUZ(2)),0)),U,13)_"mp"_$$DATE_"."_$S(BWSTYLE="X":"xml",1:"txt")
+9 SET BWPOP=$$OPEN^%ZISH(BWPATH,BWFILE,"W")
+10 IF 'BWPOP
Begin DoDot:1
+11 DO CLOSE^%ZISH()
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 DO HFSERR
SET BWPOP=1
End DoDot:1
+14 IF 'BWPOP
Begin DoDot:1
+15 WRITE !!,"Working... "
+16 ; 44=Mammography Project Procedure Type
DO LOOP(44,BWBEGDT,BWENDDT,BWSTYLE="X")
+17 SET Y=$$GTF^%ZISH($NAME(^TMP($JOB,"BWMP",1)),3,BWPATH,BWFILE)
+18 IF Y
Begin DoDot:2
+19 WRITE !!,"Number of Procedures exported: "_+$GET(PCNT)
+20 WRITE !!,"The export data has been successfully saved."
+21 WRITE !,"The '"_BWFILE_"' file was saved in the '"_BWPATH_"' folder."
End DoDot:2
End DoDot:1
+22 IF '$TEST
Begin DoDot:1
+23 DO HFSERR
SET BWPOP=1
End DoDot:1
+24 QUIT
+25 ; Collect report qualifiers
ASK ;
+1 NEW DIRUT,DIR
+2 DO DATEINFO
+3 DO ASKDATES^BWUTL3(.BWBEGDT,.BWENDDT,.BWPOP)
+4 IF 'BWPOP
Begin DoDot:1
+5 KILL DIR
+6 SET DIR(0)="S^F:Fixed Length Fields;X:XML"
+7 SET DIR("A")="Which Style"
+8 DO ^DIR
+9 IF $DATA(DIRUT)
SET BWPOP=1
+10 IF '$TEST
SET BWSTYLE=Y
End DoDot:1
+11 QUIT
LOOP(BWPTYP,BWBEGDT,BWENDDT,XML) ;
+1 NEW BWDT,BWIEN,BWMPARY,CNT,BWENDT,BW0
+2 ; Build array of active fields
+3 KILL ^TMP($JOB,"BWMP")
+4 DO BLDARY(.BWMPARY)
+5 SET XML=$GET(XML,0)
+6 IF XML
Begin DoDot:1
+7 DO ADD("<?xml version=""1.0"" encoding=""utf-8"" ?>")
+8 DO ADD("<Procedures>")
+9 DO ADD("<ExportDateRange>"_$$FMTE^XLFDT(BWBEGDT)_" to "_$$FMTE^XLFDT(BWENDDT)_"</ExportDateRange>")
End DoDot:1
+10 SET BWDT=BWBEGDT-.00001
SET BWENDT=BWENDDT+.99999
+11 FOR
SET BWDT=$ORDER(^BWPCD("D",BWDT))
IF 'BWDT!(BWDT>BWENDT)
QUIT
Begin DoDot:1
+12 SET BWIEN=0
+13 FOR
SET BWIEN=$ORDER(^BWPCD("D",BWDT,BWIEN))
IF 'BWIEN
QUIT
Begin DoDot:2
+14 IF '$DATA(^BWPCD(BWIEN,0))
KILL ^BWPCD("D",BWDT,BWIEN)
+15 SET BW0=$GET(^BWPCD(BWIEN,0))
+16 IF $PIECE($GET(^BWPCD(BWIEN,0)),U,4)'=BWPTYP
QUIT
+17 DO PROC(BWIEN,XML)
End DoDot:2
End DoDot:1
+18 IF XML
DO ADD("</Procedures>")
+19 QUIT
+20 ; Loop thru the field array for a given procedure ien
+21 ; Input: IEN - Procedure IEN
+22 ; XML - Flag indicating output style
+23 ; 0 - fixed length string per record
+24 ; 1 - XML record format
PROC(IEN,XML) ;
+1 NEW BWMMP,LBLNM,OUT,COL,LEN,BWMMP0
+2 SET BWMMP=0
+3 ;I $$WORKING(.BWSPN)
+4 SET PCNT=+$GET(PCNT)+1
+5 IF 'XML
Begin DoDot:1
+6 FOR
SET BWMMP=$ORDER(BWMPARY(BWMMP))
IF 'BWMMP
QUIT
Begin DoDot:2
+7 ;D ADD($$LBLNM(BWMPARY(BWMMP))_" = "_$$DATA(IEN,(BWMPARY(BWMMP))))
+8 SET BWMMP0=$GET(^BWMPEXP(BWMPARY(BWMMP),0))
+9 SET COL=$PIECE($PIECE(BWMMP0,U,2),",")
SET LEN=$PIECE($PIECE(BWMMP0,U,2),",",2)
+10 SET $EXTRACT(OUT,COL,COL+LEN)=$$DATA(IEN,BWMPARY(BWMMP))
End DoDot:2
+11 DO ADD(OUT)
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 DO ADD(" <Procedure>")
+14 FOR
SET BWMMP=$ORDER(BWMPARY(BWMMP))
IF 'BWMMP
QUIT
Begin DoDot:2
+15 SET LBLNM=$$LBLNM(BWMPARY(BWMMP),1)
+16 DO ADD(" <"_LBLNM_">"_$$DATA(IEN,(BWMPARY(BWMMP)))_"</"_LBLNM_">")
End DoDot:2
+17 DO ADD(" </Procedure>")
End DoDot:1
+18 QUIT
DATA(PIEN,BWMMP) ;
+1 NEW BWMMP0,FILE,FLD,FMT,VAL,FMTJ,FMTJ1,PAD,FMTD
+2 NEW EXT,PGM
+3 SET BWMMP0=$GET(^BWMPEXP(BWMMP,0))
+4 SET FILE=$PIECE($PIECE(BWMMP0,U,4),",")
+5 SET FLD=$PIECE($PIECE(BWMMP0,U,4),",",2)
+6 SET LEN=$PIECE($PIECE(BWMMP0,U,2),",",2)
+7 SET FMT=$PIECE(BWMMP0,U,5)
+8 SET VAL=""
+9 SET VAL=$$GET1^DIQ(FILE,PIEN,FLD,$SELECT(FMT["I":"I",1:"E"))
+10 IF $FIND(FMT,"Z")>0
Begin DoDot:1
+11 IF $LENGTH($GET(^BWMPEXP(BWMMP,1)))
XECUTE ^BWMPEXP(BWMMP,1)
End DoDot:1
+12 IF $FIND(FMT,"J")>0
Begin DoDot:1
+13 SET FMTJ=$FIND(FMT,"J")
SET FMTJ=$EXTRACT(FMT,FMTJ,FMTJ+1)
SET FMTJ1=$EXTRACT(FMTJ,1)
+14 SET PAD=$EXTRACT(FMTJ,2)
+15 SET PGM="VAL="_$SELECT(FMTJ1="C":"$$CJ^XLFSTR(VAL,LEN,PAD)",FMTJ1="R":"$$RJ^XLFSTR(VAL,LEN,PAD)",FMTJ1="L":"$$LJ^XLFSTR(VAL,LEN,PAD)",1:"")
+16 IF $LENGTH(PGM)>4
SET @PGM
End DoDot:1
+17 ; Check for Date format
+18 IF $FIND(FMT,"D")>0
Begin DoDot:1
+19 SET FMTD=$EXTRACT(FMT,$FIND(FMT,"D"))
+20 SET VAL=$TRANSLATE($$FMTE^XLFDT(VAL,$SELECT(FMTD=2:"7",1:"5")_"Z"),"/","")
+21 IF FMTD=3
SET VAL=$EXTRACT(VAL,1,2)_$EXTRACT(VAL,5,8)
End DoDot:1
+22 QUIT $EXTRACT(VAL,1,LEN)
+23 ; Return array containing active export fields
BLDARY(ARY) ;
+1 NEW IEN,ORDN
+2 SET IEN=0
+3 FOR
SET IEN=$ORDER(^BWMPEXP(IEN))
IF 'IEN
QUIT
Begin DoDot:1
+4 SET ORDN=+$PIECE($GET(^BWMPEXP(IEN,0)),U,3)
+5 IF ORDN>0
SET ARY(ORDN)=IEN
End DoDot:1
+6 QUIT
+7 ; Return label name for data field
+8 ; Input: BWMMP - IEN of BW MAMMOGRAPHY EXPORT DEFINITIONS (9002086.26)
+9 ; STRIP - 0: do nothing, 1: strip spaces
LBLNM(BWMMP,STRIP) ;
+1 NEW LBLNAME
+2 SET STRIP=$GET(STRIP,0)
+3 SET LBLNAME=$$GET1^DIQ(9002086.26,BWMMP,.06,"E")
+4 IF LBLNAME=""
SET LBLNAME=$$GET1^DIQ(9002086.26,BWMMP,.01,"E")
+5 QUIT $SELECT(STRIP:$$STRIP(LBLNAME),1:LBLNAME)
+6 ; Return flag indicating given race is defined for patient
+7 ; Input: PIEN - Procedure IEN
+8 ; RIEN - IEN to BW RACE File (9002086.34) or array of iens
RACE(PIEN,RIEN) ;
+1 NEW RARY,FLG,LP,RACE,I,BWDFN,PRIEN
+2 SET BWDFN=+$PIECE($GET(^BWPCD(PIEN,0)),U,2)
+3 IF 'BWDFN
QUIT 0
+4 SET I=0
FOR
SET I=$ORDER(^BWP(BWDFN,2,I))
IF 'I
QUIT
Begin DoDot:1
+5 ; Build array with patient's race iens
+6 SET PRIEN=+$GET(^BWP(BWDFN,2,I,0))
+7 IF PRIEN
SET RARY(PRIEN)=""
End DoDot:1
+8 IF $DATA(RIEN)#2
SET RIEN(-1)=RIEN
+9 SET FLG=0
SET RACE=""
FOR
SET RACE=$ORDER(RIEN(RACE))
IF RACE=""!FLG
QUIT
Begin DoDot:1
+10 IF $DATA(RARY(RIEN(RACE)))>0
SET FLG=1
End DoDot:1
+11 QUIT FLG
+12 ; Return CDC coded values for Ethinicity
+13 ; (1=Hispanic,2=Not Hispanic,3=Unknown or Declined to answer)
ETHNIC(PIEN) ;
+1 NEW BWDFN
+2 SET BWDFN=+$PIECE($GET(^BWPCD(PIEN,0)),U,2)
+3 IF 'BWDFN
QUIT 3
+4 QUIT $$HISPANIC^BWMDEX2
+5 ; Add a node to the global
ADD(VAL) ;
+1 SET CNT=+$GET(CNT)+1
+2 SET ^TMP($JOB,"BWMP",CNT)=VAL
+3 QUIT
+4 ; Strip out illegal characters for XML output
STRIP(X) ;
+1 SET X=$$STRIP^XLFSTR(X,"#/ <>()")
+2 QUIT X
+3 ; Format current date as YYYYMMDD
DATE() ;
+1 QUIT $TRANSLATE($$FMTE^XLFDT($$DT^XLFDT,"7Z"),"/","")
+2 ;
DATEINFO ;
+1 WRITE !?3,"Select date range to export."
+2 QUIT
+3 ; Displays spinning icon to indicate progress
+4 ; Input: BWAST - Start character position
+5 ; BWAP - Suppress printing
+6 ; BWAS - List of characters to print
WORKING(BWAST,BWAP,BWAS) ;
+1 QUIT 1
+2 ;Q:'$D(IO(0))!$D(ZTQUEUED) 0
+3 ;N BWAZ
+4 ;S BWAZ(0)=$I,BWAS=$G(BWAS,"|/-\"),BWAST=+$G(BWAST)
+5 ;S BWAST=$S(BWAST<0:0,1:BWAST#$L(BWAS)+1)
+6 ;U IO(0)
+7 ;W:'$G(BWAP) *8,*$S(BWAST:$A(BWAS,BWAST),1:32)
+8 ;R BWAZ#1:0 S BWAZ=$C(BWAZ)
+9 ;U BWAZ(0)
+10 ;Q BWAZ=94
+11 ;
+12 ; Display Host File Message
HFSERR ;
+1 WRITE !!?5,"* Save to Host File Server FAILED. Contact your sitemanager."
+2 DO DIRZ^BWUTLP
+3 QUIT
