- 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
