BWMDEX1 ;IHS/CIA/DKM - Convert MDE data to export format;21-Oct-2003 10:03;PLS
;;2.0;WOMEN'S HEALTH;**9**;MAY 16, 1996
EXPORT(BWFMT,BWIEN,BWGBL,BWNEW) ; EP
N BWDATA,BWLN,BWSEQ,BWDFN,BWFAC,BWPT,BWDT,BWPAP,BWMAM,BWX,X,Y,Z,P
K:$G(BWNEW) @BWGBL
; Load formatting information into BWFMT if not already done.
I $D(BWFMT)<10 D
.S X=0,BWFMT("LN")=+$P(^BWFMT(BWFMT,0),U,2)
.F S X=$O(^BWFMT(BWFMT,1,X)) Q:'X S Y=^(X,0) D
..S BWSEQ=$P(Y,U,7)*1000000+X
..F Z=2:1:9 S BWFMT(BWSEQ,Z)=$P(Y,U,Z)
..S:'$L(BWFMT(BWSEQ,8)) BWFMT(BWSEQ,8)=" "
..S BWFMT(BWSEQ,"PX")=$G(^BWFMT(BWFMT,1,X,1)),BWFMT(BWSEQ,"SX")=$G(^(2)),BWFMT(BWSEQ,"TX")=$G(^(3)),BWFMT(BWSEQ,"SC")=$G(^(4))
..M BWFMT(BWSEQ,"PR")=^BWFMT(BWFMT,1,X,20,"B")
..K:BWFMT(BWSEQ,9)!'$L(BWFMT(BWSEQ,"TX")) BWFMT(BWSEQ)
; Now loop through formatting data
D LOADDATA^BWMDEX(BWIEN)
S BWLN=+$O(@BWGBL@(""),-1),(BWSEQ,BWX)="",$E(BWX,BWFMT("LN"))=" "
F S BWSEQ=$O(BWFMT(BWSEQ)) Q:BWSEQ'=+BWSEQ D
.I $D(BWFMT(BWSEQ,"PR"))>1,'$D(BWFMT(BWSEQ,"PR",BWPT)) Q
.I $L(BWFMT(BWSEQ,"SC")) X BWFMT(BWSEQ,"SC") Q:'$T
.K X
.X BWFMT(BWSEQ,"TX")
.S Z=$L($G(X))
.Q:'Z
.S:$L(BWFMT(BWSEQ,2)) BWDATA(BWFMT(BWSEQ,2))=X
.S Y=BWFMT(BWSEQ,4)
.I Y,Y'=Z D
..I Z>Y S X=$E(X,1,Y)
..E S Z=BWFMT(BWSEQ,6),P=BWFMT(BWSEQ,8),X=$S(Z=1:$$RJ^XLFSTR(X,Y,P),Z=2:$$LJ^XLFSTR(X,Y,P),Z=3:$$CJ^XLFSTR(X,Y,P),1:X)
.S:$L(X) X=BWFMT(BWSEQ,"PX")_X_BWFMT(BWSEQ,"SX")
.S Y=BWFMT(BWSEQ,3)
.I Y S $E(BWX,Y,Y+$L(X)-1)=X
.E S BWX=BWX_X
.D:BWFMT(BWSEQ,5) OUTLN
OUTLN S:$L(BWX) BWLN=BWLN+1,@BWGBL@(BWLN)=BWX
S BWX="",$E(BWX,BWFMT("LN"))=" "
Q
; Return data from specified node and piece
PC(BWN,BWP,BWT) ;
Q $$PC^BWMDEX(.BWN,.BWP,.BWT)
; Open HFS device
; .BWFILE = Name of host file (use default if not specified)
; .BWPATH = Returned as the path to the host file
; BWTST = If nonzero, close host file after successful open.
HFSOPEN(BWFILE,BWPATH,BWTST) ; EP
D GETFILE(.BWPATH,.BWFILE)
I 'BWPOP D
.S BWPOP=$$OPEN^%ZISH(BWPATH,BWFILE,"W")
.I 'BWPOP,$G(BWTST) D ^%ZISC
.I BWPOP,'$D(BWSILENT) D
..W !!?5,"* Save to Host File Server FAILED. Contact your site manager."
..D DIRZ^BWUTLP
;IHS exemption approved on 10/20/2003
Q:$Q BWPOP
Q
; Return output filename and path
GETFILE(BWPATH,BWFILE) ;
N X
S X=$G(^BWSITE(DUZ(2),0)),BWPATH=$P(X,U,14)
I '$L(BWPATH) D
.S BWPOP=1
.W:'$D(BWSILENT) !!?5,"* No path defined in site file. Contact your site manager."
I '$D(BWFILE) D
.S BWFILE=$P(X,U,13)_$E(DT,4,5)_$E(DT,2,3)_$S('$G(BWADHOC):$$CDCVER^BWMDEX2,1:"LC")
.S:'$D(BWSILENT) BWFILE=$$DIR^BWUTLP("F","Name of output file",BWFILE,"Name of file to receive output.",.BWPOP)
Q
; Send extract results to output device
OUTPUT(BWGBL,BWADHOC,BWFILE) ; EP
N BWCOUNT,BWHFS,BWPATH,X
I '$D(@BWGBL) D:'$D(BWSILENT) Q
.W !!?5,"No records to be exported."
.D DIRZ^BWUTLP
;
; If this is an adhoc query then offer to write file out to alternate device.
I '$D(BWSILENT),BWADHOC D Q:BWPOP
.W !!,"Do you wish to save your results to a file or send them to"
.W !,"an alternate device?"
.S BWHFS=$$DIR^BWUTLP("SA^0:OTHER;1:FILE","Select FILE or OTHER: ","FILE",1,.BWPOP)
E S BWHFS=1
I BWHFS D
.D HFSOPEN(.BWFILE,.BWPATH)
E D
.D ^%ZIS
.S BWPOP=POP
Q:BWPOP
U IO
S (X,BWCOUNT)=0
F BWCOUNT=0:1 S X=$O(@BWGBL@(X)) Q:'X W @BWGBL@(X),!
D ^%ZISC
D:BWHFS SHOWDLG^BWUTLP(12_U_BWFILE_U_BWPATH)
; Offer to log if not an ad hoc extract
I 'BWADHOC D
.I '$D(BWSILENT),'$$DIRYN^BWUTLP(6,"YES",7) Q
.D FILE^BWFMAN(9002086.92,".02////"_BWCOUNT_";.03////"_BWPATH_BWFILE,"ML",DT,9002086,.X)
.D:X<0 SHOWDLG^BWUTLP(-5)
Q
BWMDEX1 ;IHS/CIA/DKM - Convert MDE data to export format;21-Oct-2003 10:03;PLS
+1 ;;2.0;WOMEN'S HEALTH;**9**;MAY 16, 1996
EXPORT(BWFMT,BWIEN,BWGBL,BWNEW) ; EP
+1 NEW BWDATA,BWLN,BWSEQ,BWDFN,BWFAC,BWPT,BWDT,BWPAP,BWMAM,BWX,X,Y,Z,P
+2 IF $GET(BWNEW)
KILL @BWGBL
+3 ; Load formatting information into BWFMT if not already done.
+4 IF $DATA(BWFMT)<10
Begin DoDot:1
+5 SET X=0
SET BWFMT("LN")=+$PIECE(^BWFMT(BWFMT,0),U,2)
+6 FOR
SET X=$ORDER(^BWFMT(BWFMT,1,X))
IF 'X
QUIT
SET Y=^(X,0)
Begin DoDot:2
+7 SET BWSEQ=$PIECE(Y,U,7)*1000000+X
+8 FOR Z=2:1:9
SET BWFMT(BWSEQ,Z)=$PIECE(Y,U,Z)
+9 IF '$LENGTH(BWFMT(BWSEQ,8))
SET BWFMT(BWSEQ,8)=" "
+10 SET BWFMT(BWSEQ,"PX")=$GET(^BWFMT(BWFMT,1,X,1))
SET BWFMT(BWSEQ,"SX")=$GET(^(2))
SET BWFMT(BWSEQ,"TX")=$GET(^(3))
SET BWFMT(BWSEQ,"SC")=$GET(^(4))
+11 MERGE BWFMT(BWSEQ,"PR")=^BWFMT(BWFMT,1,X,20,"B")
+12 IF BWFMT(BWSEQ,9)!'$LENGTH(BWFMT(BWSEQ,"TX"))
KILL BWFMT(BWSEQ)
End DoDot:2
End DoDot:1
+13 ; Now loop through formatting data
+14 DO LOADDATA^BWMDEX(BWIEN)
+15 SET BWLN=+$ORDER(@BWGBL@(""),-1)
SET (BWSEQ,BWX)=""
SET $EXTRACT(BWX,BWFMT("LN"))=" "
+16 FOR
SET BWSEQ=$ORDER(BWFMT(BWSEQ))
IF BWSEQ'=+BWSEQ
QUIT
Begin DoDot:1
+17 IF $DATA(BWFMT(BWSEQ,"PR"))>1
IF '$DATA(BWFMT(BWSEQ,"PR",BWPT))
QUIT
+18 IF $LENGTH(BWFMT(BWSEQ,"SC"))
XECUTE BWFMT(BWSEQ,"SC")
IF '$TEST
QUIT
+19 KILL X
+20 XECUTE BWFMT(BWSEQ,"TX")
+21 SET Z=$LENGTH($GET(X))
+22 IF 'Z
QUIT
+23 IF $LENGTH(BWFMT(BWSEQ,2))
SET BWDATA(BWFMT(BWSEQ,2))=X
+24 SET Y=BWFMT(BWSEQ,4)
+25 IF Y
IF Y'=Z
Begin DoDot:2
+26 IF Z>Y
SET X=$EXTRACT(X,1,Y)
+27 IF '$TEST
SET Z=BWFMT(BWSEQ,6)
SET P=BWFMT(BWSEQ,8)
SET X=$SELECT(Z=1:$$RJ^XLFSTR(X,Y,P),Z=2:$$LJ^XLFSTR(X,Y,P),Z=3:$$CJ^XLFSTR(X,Y,P),1:X)
End DoDot:2
+28 IF $LENGTH(X)
SET X=BWFMT(BWSEQ,"PX")_X_BWFMT(BWSEQ,"SX")
+29 SET Y=BWFMT(BWSEQ,3)
+30 IF Y
SET $EXTRACT(BWX,Y,Y+$LENGTH(X)-1)=X
+31 IF '$TEST
SET BWX=BWX_X
+32 IF BWFMT(BWSEQ,5)
DO OUTLN
End DoDot:1
OUTLN IF $LENGTH(BWX)
SET BWLN=BWLN+1
SET @BWGBL@(BWLN)=BWX
+1 SET BWX=""
SET $EXTRACT(BWX,BWFMT("LN"))=" "
+2 QUIT
+3 ; Return data from specified node and piece
PC(BWN,BWP,BWT) ;
+1 QUIT $$PC^BWMDEX(.BWN,.BWP,.BWT)
+2 ; Open HFS device
+3 ; .BWFILE = Name of host file (use default if not specified)
+4 ; .BWPATH = Returned as the path to the host file
+5 ; BWTST = If nonzero, close host file after successful open.
HFSOPEN(BWFILE,BWPATH,BWTST) ; EP
+1 DO GETFILE(.BWPATH,.BWFILE)
+2 IF 'BWPOP
Begin DoDot:1
+3 SET BWPOP=$$OPEN^%ZISH(BWPATH,BWFILE,"W")
+4 IF 'BWPOP
IF $GET(BWTST)
DO ^%ZISC
+5 IF BWPOP
IF '$DATA(BWSILENT)
Begin DoDot:2
+6 WRITE !!?5,"* Save to Host File Server FAILED. Contact your site manager."
+7 DO DIRZ^BWUTLP
End DoDot:2
End DoDot:1
+8 ;IHS exemption approved on 10/20/2003
+9 IF $QUIT
QUIT BWPOP
+10 QUIT
+11 ; Return output filename and path
GETFILE(BWPATH,BWFILE) ;
+1 NEW X
+2 SET X=$GET(^BWSITE(DUZ(2),0))
SET BWPATH=$PIECE(X,U,14)
+3 IF '$LENGTH(BWPATH)
Begin DoDot:1
+4 SET BWPOP=1
+5 IF '$DATA(BWSILENT)
WRITE !!?5,"* No path defined in site file. Contact your site manager."
End DoDot:1
+6 IF '$DATA(BWFILE)
Begin DoDot:1
+7 SET BWFILE=$PIECE(X,U,13)_$EXTRACT(DT,4,5)_$EXTRACT(DT,2,3)_$SELECT('$GET(BWADHOC):$$CDCVER^BWMDEX2,1:"LC")
+8 IF '$DATA(BWSILENT)
SET BWFILE=$$DIR^BWUTLP("F","Name of output file",BWFILE,"Name of file to receive output.",.BWPOP)
End DoDot:1
+9 QUIT
+10 ; Send extract results to output device
OUTPUT(BWGBL,BWADHOC,BWFILE) ; EP
+1 NEW BWCOUNT,BWHFS,BWPATH,X
+2 IF '$DATA(@BWGBL)
IF '$DATA(BWSILENT)
Begin DoDot:1
+3 WRITE !!?5,"No records to be exported."
+4 DO DIRZ^BWUTLP
End DoDot:1
QUIT
+5 ;
+6 ; If this is an adhoc query then offer to write file out to alternate device.
+7 IF '$DATA(BWSILENT)
IF BWADHOC
Begin DoDot:1
+8 WRITE !!,"Do you wish to save your results to a file or send them to"
+9 WRITE !,"an alternate device?"
+10 SET BWHFS=$$DIR^BWUTLP("SA^0:OTHER;1:FILE","Select FILE or OTHER: ","FILE",1,.BWPOP)
End DoDot:1
IF BWPOP
QUIT
+11 IF '$TEST
SET BWHFS=1
+12 IF BWHFS
Begin DoDot:1
+13 DO HFSOPEN(.BWFILE,.BWPATH)
End DoDot:1
+14 IF '$TEST
Begin DoDot:1
+15 DO ^%ZIS
+16 SET BWPOP=POP
End DoDot:1
+17 IF BWPOP
QUIT
+18 USE IO
+19 SET (X,BWCOUNT)=0
+20 FOR BWCOUNT=0:1
SET X=$ORDER(@BWGBL@(X))
IF 'X
QUIT
WRITE @BWGBL@(X),!
+21 DO ^%ZISC
+22 IF BWHFS
DO SHOWDLG^BWUTLP(12_U_BWFILE_U_BWPATH)
+23 ; Offer to log if not an ad hoc extract
+24 IF 'BWADHOC
Begin DoDot:1
+25 IF '$DATA(BWSILENT)
IF '$$DIRYN^BWUTLP(6,"YES",7)
QUIT
+26 DO FILE^BWFMAN(9002086.92,".02////"_BWCOUNT_";.03////"_BWPATH_BWFILE,"ML",DT,9002086,.X)
+27 IF X<0
DO SHOWDLG^BWUTLP(-5)
End DoDot:1
+28 QUIT
