BWUTL5 ;IHS/ANMC/MWR/HJT - UTIL: ACC#, TITLES, SL/TX DATES;15-Feb-2003 22:14;PLS
;;2.0;WOMEN'S HEALTH;**5,8**;MAY 16, 1996
;Modified for Y2k Compliance 5/14/1999 IHS/DSD/HJT
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; UTILITY: SETVARS, GENERATE ACCESSION#, MENUT, TITLE, CENTERT,
;; COPYLET, UPPERCASE XREF, CDC, SL/TX DATES.
;
;
SETVARS ;EP
D XBKVAR
S:'$D(IOF) IOF="#"
S:'$D(BWPOP) BWPOP=0
Q
;**************
;---> XBKVAR INCORPORATED HERE FOR VA COMPATIBILITY.
XBKVAR ;SET MINIMUM KERNEL VARIABLES;
; FROM ;;2.5;XB;;MAR 20, 1991
; FROM ;IHS/DSD/JCM 7/6/92 Added Set of DUZ("AG")
;
S U="^"
I '$D(DUZ(2)),$D(^AUTTSITE(1,0)) S DUZ(2)=+^(0)
I '$D(DUZ(2)),$D(^AUTTLOC("SITE")) S DUZ(2)=+^(0)
I '$D(DUZ("AG")) S DUZ("AG")=$S($P($G(^XMB(1,0)),"^",8)]"":$P(^XMB(1,0),"^",8),1:"I") ;IHS/DSD/JCM 7/6/92
S:'($D(DUZ)#2) DUZ=0 S:'($D(DUZ(0))#2) DUZ(0)="" S:'($D(DUZ(2))#2) DUZ(2)=0
I '$D(DT) D NOW^%DTC S DT=X
S:'$D(DTIME) DTIME=999
K %,%H,%I
Q
;**************
;
;
ACCSSN(PCDTYPE) ;EP
;---> GENERATE ACCESSION# FOR BW PROCEDURE FILE ENTRY.
;---> REQUIRED VARIABLE: PCDTYPE=IEN OF PROCEDURE TYPE (#9002086.2)
N A,C,L,N,P,X
Q:'$D(PCDTYPE) ""
Q:'$D(^BWPN(PCDTYPE,0)) ""
S X=^BWPN(PCDTYPE,0) ;X=0-NODE OF PROC TYPE
S P=$P(X,U,4) ;P=PREFIX
S L=$P(X,U,6) ;L=LAST ASSIGNED ACCESSION# FOR THIS PROC
S A=$P(L,"-") ;A=ACC YEAR
S C=$P(L,"-",2) ;C=COUNTER
D NOW^%DTC S N=$E(%I(3),2,3) ;N=YEAR NOW: 94
I A'=N S C=0
F L +^BWPN(PCDTYPE,0):1 Q:$T
F S C=C+1 S R=P_N_"-"_C Q:'$D(^BWPCD("B",R))
S $P(^BWPN(PCDTYPE,0),U,6)=N_"-"_C
L -^BWPN(PCDTYPE,0)
Q R ;R=RESULT(NEW ACCESSION#)
;
;---> DISPLAY MENU TITLE FROM BW MENU OPTIONS.
;---> REQUIRED VARIABLES: TITLE=TEXT TO BE CENTERED AND DISPLAYED.
;---> DUZ(2)=CURRENT LOCATION TO BE DISPLAYED.
N BWTTAB,BWFAC,BWUNL,I
S:'$D(TITLE) TITLE="* NO TITLE SUPPLIED *"
S TITLE="* "_TITLE_" *"
S BWTTAB=39-($L(TITLE)/2)
W:$D(IOF) @IOF
W !?3,"WOMEN'S HEALTH:"
W ?BWTTAB,TITLE
W ?60,$E($$INSTTX^BWUTL6(DUZ(2)),1,20)
S BWUNL="" F I=1:1:$L(TITLE) S BWUNL=BWUNL_"="
W !?BWTTAB,BWUNL
Q
;
TITLE(TITLE) ;EP
;---> DISPLAY A TITLE.
;---> REQUIRED VARIABLES: TITLE=TEXT TO BE CENTERED AND DISPLAYED.
N BWTTAB
S:'$D(TITLE) TITLE="* NO TITLE SUPPLIED *"
S TITLE="* * * WOMEN'S HEALTH: "_TITLE_" * * *"
S BWTTAB=39-($L(TITLE)/2)
W:$D(IOF) @IOF
W !?BWTTAB,TITLE,!!
Q
;
CENTERT(TEXT) ;EP
;---> ADD LEADING SPACES TO CENTER TEXT.
S:'$D(TEXT) TEXT="* NO TEXT SUPPLIED *"
N I
F I=1:1:(39-($L(TEXT)/2)) S TEXT=" "_TEXT
Q
;
UPPER() ;EP
S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Q X
;
COPYLET ;EP
;---> COPY TEXT OF GENERIC SAMPLE LETTER TO ONE OR MORE BW PURPOSES.
;---> EDIT NEXT LINE TO INCLUDE IENS OF BW PURPOSES TO BE CHANGED.
;F DA=15,16,18,19 D
S DA=0
F S DA=$O(^BWNOTP(DA)) Q:'DA D
.K ^BWNOTP(DA,1)
.S N=0
.F S N=$O(^BWLET(1,1,N)) Q:'N D
..S ^BWNOTP(DA,1,N,0)=^BWLET(1,1,N,0)
.S ^BWNOTP(DA,1,0)=^BWLET(1,1,0)
Q
;
;
UPXREF(X,BWGBL) ;EP
;---> SET UPPERCASE XREF FOR X. CALLED FROM MUMPS XREFS ON MIXED CASE
;---> FIELDS WHERE AN ALL UPPERCASE LOOKUP IS NEEDED.
;---> REQUIRED VARIABLES: BWGBL=GLOBAL ROOT OF FILE, X=TEXT TO BE
;---> CROSSREFERENCED IN ALL UPPERCASE, DA=IEN.
Q:'$D(BWGBL)!('$D(X))
N BWX S BWX=X,X=$$UPPER
S @(BWGBL_"""U"",$E(X,1,30),DA)")=""
S X=BWX K BWGBL
Q
;
KUPXREF(X,BWGBL) ;EP
;---> KILL UPPERCASE XREF FOR X. CALLED FROM MUMPS XREFS ON MIXED CASE
;---> FIELDS WHERE AN ALL UPPERCASE LOOKUP IS NEEDED.
;---> REQUIRED VARIABLES: BWGBL=GLOBAL ROOT OF FILE, X=TEXT TO BE
;---> CROSSREFERENCED IN ALL UPPERCASE, DA=IEN.
Q:'$D(BWGBL)!('$D(X))
N BWX S BWX=X,X=$$UPPER
K @(BWGBL_"""U"",$E(X,1,30),DA)")
S X=BWX K BWGBL
Q
;
CDC(SITE) ;EP
;---> RETURN 1 IF THIS SITE IS EXPORTING DATA TO CDC.
Q:'$G(SITE) ""
Q:'$D(^BWSITE(SITE,0)) ""
Q $P(^BWSITE(SITE,0),U,12)
;
AGENCY(SITE) ;EP
;---> RETURN TYPE OF AGENCY ("i"=IHS, "s"=STATE, "v"=VA, ETC.).
;---> REQUIRED VARIABLE: SITE=DUZ(2)
;---> IF SITE NOT PASSED OR PARAMETER NOT SET, IT DEFAULTS TO IHS.
Q:'$G(SITE) "i"
Q:'$D(^BWSITE(SITE,0)) "i"
Q $P(^BWSITE(SITE,0),U,15)
;
PNLAB(SITE) ;EP
;---> RETURN TEXT FOR PATIENT NUMBER: "Chart#: " OR " SSN: ".
I $$AGENCY(SITE)="i" Q "Chart#: "
Q " SSN: "
;
PNLB(SITE) ;EP
;---> RETURN UPPERCASE TEXT FOR PATIENT NUMBER, NO COLON/SPACES.
I $$AGENCY(SITE)="i" Q "CHART#"
Q "SSN"
;
CDCID(DFN,SITE) ;EP
;---> GENERATE A UNIQUE PATIENT INDENTIFIER FOR CDC MDE EXPORT.
Q:'$$CDC(SITE) ""
;---> QUIT IF ONE ALREADY EXISTS FOR THIS PATIENT.
I $D(^BWP(DFN,0)) Q:$P(^(0),U,20)]"" ""
N I,Y,Z
;---> TAKE FIRST 4 CHARS OF LAST NAME (EXCHG PUNCTUATION FOR ZEROS).
S Y=$E($P($$NAME^BWUTL1(DFN),","),1,4)
S Y=$TR(Y," '-.,","00000")
F I=1:1:(4-$L(Y)) S Y=Y_0
;---> TAKE FIRST INITIAL.
S Z=$E($P($$NAME^BWUTL1(DFN),",",2)) S:Z="" Z=0
;---> CONCATENATE IN REVERSE ORDER.
S Y=$E(Y,4)_$E(Y,3)_$E(Y,2)_$E(Y)_Z
;---> CONCATENATE FILEMAN DATE OF BIRTH.
S Y=Y_$E($$DOB^BWUTL1(DFN),2,7)
;---> CONCATENATE LAST 4 DIGITS OF SSN (OR 9999 IF NO SSN).
S I=$E($$SSN^BWUTL1(DFN),6,9) S:'+I I=9999
Q Y_I
;
CDCEXP(IEN,SITE) ;EP
;---> RETURNS 1 IF THIS PROCEDURE AT THIS SITE SHOULD BE FLAGGED FOR
;---> EXPORT TO CDC. IEN=IEN IN BW PROCEDURE TYPE FILE #9002086.2.
Q:'$G(IEN) ""
;---> QUIT IF SITE NOT EXPORTING MDE'S TO CDC.
Q:'$$CDC(SITE) ""
Q:'$D(^BWPN(IEN)) ""
;---> QUIT IF PROCEDURE SHOULD NOT BE EXPORTED.
Q:'$P(^BWPN(IEN,0),U,13) ""
Q 1
;
SLDT2(DATE) ;EP
;---> CONVERT FILEMAN INTERNAL DATE TO "SLASH" FORMAT: MM/DD/YY.
;---> DATE=DATE IN FILEMAN FORMAT.
Q:'$G(DATE) "NO DATE"
S DATE=$P(DATE,".")
Q:$L(DATE)'=7 DATE
Q:'$E(DATE,4,5) $E(DATE,1,3)+1700
;Begin Y2k fix 5/14/1999 IHS/DSD/HJT
;Q:'$E(DATE,6,7) $E(DATE,4,5)_"/"_$E(DATE,2,3)
Q:'$E(DATE,6,7) $E(DATE,4,5)_"/"_($E(DATE,1,3)+1700) ;Y2000
;Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3)
Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_($E(DATE,1,3)+1700) ;Y2000
;End Y2k fix
;
;
SLDT1(DATE) ;EP
;---> CONVERT FILEMAN INTERNAL DATE TO "SLASH" FORMAT: MM/DD/YY
;---> PLUS TIME.
N Y
Q:'$D(DATE) "unknown"
S Y=DATE,DATE=$P(DATE,".")
Q:'DATE "NO DATE"
Q:$L(DATE)'=7 DATE
Q:'$E(DATE,4,5) $E(DATE,1,3)+1700
;Begin Y2k fix
;Q:'$E(DATE,6,7) $E(DATE,4,5)_"/"_$E(DATE,2,3)
Q:'$E(DATE,6,7) $E(DATE,4,5)_"/"_($E(DATE,1,3)+1700) ;Y2000
D DD^%DT S:Y["@" Y=" @ "_$P($P(Y,"@",2),":",1,2)
;Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3)_Y
Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_($E(DATE,1,3)+1700)_Y ;Y2000
;End Y2k fix
;
TXDT(DATE) ;EP
;---> CONVERT FILEMAN INTERNAL DATE TO "TEXT" FORMAT: MMM DD,YYYY.
N Y
Q:'$D(DATE) "UNKNOWN"
S Y=DATE D DD^%DT
I Y[", " S Y=$P(Y,", ")_","_$P(Y,", ",2)
I Y["@" S Y=$P(Y,"@")_" "_$P($P(Y,"@",2),":",1,2)
Q Y
BWUTL5 ;IHS/ANMC/MWR/HJT - UTIL: ACC#, TITLES, SL/TX DATES;15-Feb-2003 22:14;PLS
+1 ;;2.0;WOMEN'S HEALTH;**5,8**;MAY 16, 1996
+2 ;Modified for Y2k Compliance 5/14/1999 IHS/DSD/HJT
+3 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+4 ;; UTILITY: SETVARS, GENERATE ACCESSION#, MENUT, TITLE, CENTERT,
+5 ;; COPYLET, UPPERCASE XREF, CDC, SL/TX DATES.
+6 ;
+7 ;
SETVARS ;EP
+1 DO XBKVAR
+2 IF '$DATA(IOF)
SET IOF="#"
+3 IF '$DATA(BWPOP)
SET BWPOP=0
+4 QUIT
+5 ;**************
+6 ;---> XBKVAR INCORPORATED HERE FOR VA COMPATIBILITY.
XBKVAR ;SET MINIMUM KERNEL VARIABLES;
+1 ; FROM ;;2.5;XB;;MAR 20, 1991
+2 ; FROM ;IHS/DSD/JCM 7/6/92 Added Set of DUZ("AG")
+3 ;
+4 SET U="^"
+5 IF '$DATA(DUZ(2))
IF $DATA(^AUTTSITE(1,0))
SET DUZ(2)=+^(0)
+6 IF '$DATA(DUZ(2))
IF $DATA(^AUTTLOC("SITE"))
SET DUZ(2)=+^(0)
+7 ;IHS/DSD/JCM 7/6/92
IF '$DATA(DUZ("AG"))
SET DUZ("AG")=$SELECT($PIECE($GET(^XMB(1,0)),"^",8)]"":$PIECE(^XMB(1,0),"^",8),1:"I")
+8 IF '($DATA(DUZ)#2)
SET DUZ=0
IF '($DATA(DUZ(0))#2)
SET DUZ(0)=""
IF '($DATA(DUZ(2))#2)
SET DUZ(2)=0
+9 IF '$DATA(DT)
DO NOW^%DTC
SET DT=X
+10 IF '$DATA(DTIME)
SET DTIME=999
+11 KILL %,%H,%I
+12 QUIT
+13 ;**************
+14 ;
+15 ;
ACCSSN(PCDTYPE) ;EP
+1 ;---> GENERATE ACCESSION# FOR BW PROCEDURE FILE ENTRY.
+2 ;---> REQUIRED VARIABLE: PCDTYPE=IEN OF PROCEDURE TYPE (#9002086.2)
+3 NEW A,C,L,N,P,X
+4 IF '$DATA(PCDTYPE)
QUIT ""
+5 IF '$DATA(^BWPN(PCDTYPE,0))
QUIT ""
+6 ;X=0-NODE OF PROC TYPE
SET X=^BWPN(PCDTYPE,0)
+7 ;P=PREFIX
SET P=$PIECE(X,U,4)
+8 ;L=LAST ASSIGNED ACCESSION# FOR THIS PROC
SET L=$PIECE(X,U,6)
+9 ;A=ACC YEAR
SET A=$PIECE(L,"-")
+10 ;C=COUNTER
SET C=$PIECE(L,"-",2)
+11 ;N=YEAR NOW: 94
DO NOW^%DTC
SET N=$EXTRACT(%I(3),2,3)
+12 IF A'=N
SET C=0
+13 FOR
LOCK +^BWPN(PCDTYPE,0):1
IF $TEST
QUIT
+14 FOR
SET C=C+1
SET R=P_N_"-"_C
IF '$DATA(^BWPCD("B",R))
QUIT
+15 SET $PIECE(^BWPN(PCDTYPE,0),U,6)=N_"-"_C
+16 LOCK -^BWPN(PCDTYPE,0)
+17 ;R=RESULT(NEW ACCESSION#)
QUIT R
+18 ;
+1 ;---> DISPLAY MENU TITLE FROM BW MENU OPTIONS.
+2 ;---> REQUIRED VARIABLES: TITLE=TEXT TO BE CENTERED AND DISPLAYED.
+3 ;---> DUZ(2)=CURRENT LOCATION TO BE DISPLAYED.
+4 NEW BWTTAB,BWFAC,BWUNL,I
+5 IF '$DATA(TITLE)
SET TITLE="* NO TITLE SUPPLIED *"
+6 SET TITLE="* "_TITLE_" *"
+7 SET BWTTAB=39-($LENGTH(TITLE)/2)
+8 IF $DATA(IOF)
WRITE @IOF
+9 WRITE !?3,"WOMEN'S HEALTH:"
+10 WRITE ?BWTTAB,TITLE
+11 WRITE ?60,$EXTRACT($$INSTTX^BWUTL6(DUZ(2)),1,20)
+12 SET BWUNL=""
FOR I=1:1:$LENGTH(TITLE)
SET BWUNL=BWUNL_"="
+13 WRITE !?BWTTAB,BWUNL
+14 QUIT
+15 ;
TITLE(TITLE) ;EP
+1 ;---> DISPLAY A TITLE.
+2 ;---> REQUIRED VARIABLES: TITLE=TEXT TO BE CENTERED AND DISPLAYED.
+3 NEW BWTTAB
+4 IF '$DATA(TITLE)
SET TITLE="* NO TITLE SUPPLIED *"
+5 SET TITLE="* * * WOMEN'S HEALTH: "_TITLE_" * * *"
+6 SET BWTTAB=39-($LENGTH(TITLE)/2)
+7 IF $DATA(IOF)
WRITE @IOF
+8 WRITE !?BWTTAB,TITLE,!!
+9 QUIT
+10 ;
CENTERT(TEXT) ;EP
+1 ;---> ADD LEADING SPACES TO CENTER TEXT.
+2 IF '$DATA(TEXT)
SET TEXT="* NO TEXT SUPPLIED *"
+3 NEW I
+4 FOR I=1:1:(39-($LENGTH(TEXT)/2))
SET TEXT=" "_TEXT
+5 QUIT
+6 ;
UPPER() ;EP
+1 SET X=$TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 QUIT X
+3 ;
COPYLET ;EP
+1 ;---> COPY TEXT OF GENERIC SAMPLE LETTER TO ONE OR MORE BW PURPOSES.
+2 ;---> EDIT NEXT LINE TO INCLUDE IENS OF BW PURPOSES TO BE CHANGED.
+3 ;F DA=15,16,18,19 D
+4 SET DA=0
+5 FOR
SET DA=$ORDER(^BWNOTP(DA))
IF 'DA
QUIT
Begin DoDot:1
+6 KILL ^BWNOTP(DA,1)
+7 SET N=0
+8 FOR
SET N=$ORDER(^BWLET(1,1,N))
IF 'N
QUIT
Begin DoDot:2
+9 SET ^BWNOTP(DA,1,N,0)=^BWLET(1,1,N,0)
End DoDot:2
+10 SET ^BWNOTP(DA,1,0)=^BWLET(1,1,0)
End DoDot:1
+11 QUIT
+12 ;
+13 ;
UPXREF(X,BWGBL) ;EP
+1 ;---> SET UPPERCASE XREF FOR X. CALLED FROM MUMPS XREFS ON MIXED CASE
+2 ;---> FIELDS WHERE AN ALL UPPERCASE LOOKUP IS NEEDED.
+3 ;---> REQUIRED VARIABLES: BWGBL=GLOBAL ROOT OF FILE, X=TEXT TO BE
+4 ;---> CROSSREFERENCED IN ALL UPPERCASE, DA=IEN.
+5 IF '$DATA(BWGBL)!('$DATA(X))
QUIT
+6 NEW BWX
SET BWX=X
SET X=$$UPPER
+7 SET @(BWGBL_"""U"",$E(X,1,30),DA)")=""
+8 SET X=BWX
KILL BWGBL
+9 QUIT
+10 ;
KUPXREF(X,BWGBL) ;EP
+1 ;---> KILL UPPERCASE XREF FOR X. CALLED FROM MUMPS XREFS ON MIXED CASE
+2 ;---> FIELDS WHERE AN ALL UPPERCASE LOOKUP IS NEEDED.
+3 ;---> REQUIRED VARIABLES: BWGBL=GLOBAL ROOT OF FILE, X=TEXT TO BE
+4 ;---> CROSSREFERENCED IN ALL UPPERCASE, DA=IEN.
+5 IF '$DATA(BWGBL)!('$DATA(X))
QUIT
+6 NEW BWX
SET BWX=X
SET X=$$UPPER
+7 KILL @(BWGBL_"""U"",$E(X,1,30),DA)")
+8 SET X=BWX
KILL BWGBL
+9 QUIT
+10 ;
CDC(SITE) ;EP
+1 ;---> RETURN 1 IF THIS SITE IS EXPORTING DATA TO CDC.
+2 IF '$GET(SITE)
QUIT ""
+3 IF '$DATA(^BWSITE(SITE,0))
QUIT ""
+4 QUIT $PIECE(^BWSITE(SITE,0),U,12)
+5 ;
AGENCY(SITE) ;EP
+1 ;---> RETURN TYPE OF AGENCY ("i"=IHS, "s"=STATE, "v"=VA, ETC.).
+2 ;---> REQUIRED VARIABLE: SITE=DUZ(2)
+3 ;---> IF SITE NOT PASSED OR PARAMETER NOT SET, IT DEFAULTS TO IHS.
+4 IF '$GET(SITE)
QUIT "i"
+5 IF '$DATA(^BWSITE(SITE,0))
QUIT "i"
+6 QUIT $PIECE(^BWSITE(SITE,0),U,15)
+7 ;
PNLAB(SITE) ;EP
+1 ;---> RETURN TEXT FOR PATIENT NUMBER: "Chart#: " OR " SSN: ".
+2 IF $$AGENCY(SITE)="i"
QUIT "Chart#: "
+3 QUIT " SSN: "
+4 ;
PNLB(SITE) ;EP
+1 ;---> RETURN UPPERCASE TEXT FOR PATIENT NUMBER, NO COLON/SPACES.
+2 IF $$AGENCY(SITE)="i"
QUIT "CHART#"
+3 QUIT "SSN"
+4 ;
CDCID(DFN,SITE) ;EP
+1 ;---> GENERATE A UNIQUE PATIENT INDENTIFIER FOR CDC MDE EXPORT.
+2 IF '$$CDC(SITE)
QUIT ""
+3 ;---> QUIT IF ONE ALREADY EXISTS FOR THIS PATIENT.
+4 IF $DATA(^BWP(DFN,0))
IF $PIECE(^(0),U,20)]""
QUIT ""
+5 NEW I,Y,Z
+6 ;---> TAKE FIRST 4 CHARS OF LAST NAME (EXCHG PUNCTUATION FOR ZEROS).
+7 SET Y=$EXTRACT($PIECE($$NAME^BWUTL1(DFN),","),1,4)
+8 SET Y=$TRANSLATE(Y," '-.,","00000")
+9 FOR I=1:1:(4-$LENGTH(Y))
SET Y=Y_0
+10 ;---> TAKE FIRST INITIAL.
+11 SET Z=$EXTRACT($PIECE($$NAME^BWUTL1(DFN),",",2))
IF Z=""
SET Z=0
+12 ;---> CONCATENATE IN REVERSE ORDER.
+13 SET Y=$EXTRACT(Y,4)_$EXTRACT(Y,3)_$EXTRACT(Y,2)_$EXTRACT(Y)_Z
+14 ;---> CONCATENATE FILEMAN DATE OF BIRTH.
+15 SET Y=Y_$EXTRACT($$DOB^BWUTL1(DFN),2,7)
+16 ;---> CONCATENATE LAST 4 DIGITS OF SSN (OR 9999 IF NO SSN).
+17 SET I=$EXTRACT($$SSN^BWUTL1(DFN),6,9)
IF '+I
SET I=9999
+18 QUIT Y_I
+19 ;
CDCEXP(IEN,SITE) ;EP
+1 ;---> RETURNS 1 IF THIS PROCEDURE AT THIS SITE SHOULD BE FLAGGED FOR
+2 ;---> EXPORT TO CDC. IEN=IEN IN BW PROCEDURE TYPE FILE #9002086.2.
+3 IF '$GET(IEN)
QUIT ""
+4 ;---> QUIT IF SITE NOT EXPORTING MDE'S TO CDC.
+5 IF '$$CDC(SITE)
QUIT ""
+6 IF '$DATA(^BWPN(IEN))
QUIT ""
+7 ;---> QUIT IF PROCEDURE SHOULD NOT BE EXPORTED.
+8 IF '$PIECE(^BWPN(IEN,0),U,13)
QUIT ""
+9 QUIT 1
+10 ;
SLDT2(DATE) ;EP
+1 ;---> CONVERT FILEMAN INTERNAL DATE TO "SLASH" FORMAT: MM/DD/YY.
+2 ;---> DATE=DATE IN FILEMAN FORMAT.
+3 IF '$GET(DATE)
QUIT "NO DATE"
+4 SET DATE=$PIECE(DATE,".")
+5 IF $LENGTH(DATE)'=7
QUIT DATE
+6 IF '$EXTRACT(DATE,4,5)
QUIT $EXTRACT(DATE,1,3)+1700
+7 ;Begin Y2k fix 5/14/1999 IHS/DSD/HJT
+8 ;Q:'$E(DATE,6,7) $E(DATE,4,5)_"/"_$E(DATE,2,3)
+9 ;Y2000
IF '$EXTRACT(DATE,6,7)
QUIT $EXTRACT(DATE,4,5)_"/"_($EXTRACT(DATE,1,3)+1700)
+10 ;Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3)
+11 ;Y2000
QUIT $EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,6,7)_"/"_($EXTRACT(DATE,1,3)+1700)
+12 ;End Y2k fix
+13 ;
+14 ;
SLDT1(DATE) ;EP
+1 ;---> CONVERT FILEMAN INTERNAL DATE TO "SLASH" FORMAT: MM/DD/YY
+2 ;---> PLUS TIME.
+3 NEW Y
+4 IF '$DATA(DATE)
QUIT "unknown"
+5 SET Y=DATE
SET DATE=$PIECE(DATE,".")
+6 IF 'DATE
QUIT "NO DATE"
+7 IF $LENGTH(DATE)'=7
QUIT DATE
+8 IF '$EXTRACT(DATE,4,5)
QUIT $EXTRACT(DATE,1,3)+1700
+9 ;Begin Y2k fix
+10 ;Q:'$E(DATE,6,7) $E(DATE,4,5)_"/"_$E(DATE,2,3)
+11 ;Y2000
IF '$EXTRACT(DATE,6,7)
QUIT $EXTRACT(DATE,4,5)_"/"_($EXTRACT(DATE,1,3)+1700)
+12 DO DD^%DT
IF Y["@"
SET Y=" @ "_$PIECE($PIECE(Y,"@",2),":",1,2)
+13 ;Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3)_Y
+14 ;Y2000
QUIT $EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,6,7)_"/"_($EXTRACT(DATE,1,3)+1700)_Y
+15 ;End Y2k fix
+16 ;
TXDT(DATE) ;EP
+1 ;---> CONVERT FILEMAN INTERNAL DATE TO "TEXT" FORMAT: MMM DD,YYYY.
+2 NEW Y
+3 IF '$DATA(DATE)
QUIT "UNKNOWN"
+4 SET Y=DATE
DO DD^%DT
+5 IF Y[", "
SET Y=$PIECE(Y,", ")_","_$PIECE(Y,", ",2)
+6 IF Y["@"
SET Y=$PIECE(Y,"@")_" "_$PIECE($PIECE(Y,"@",2),":",1,2)
+7 QUIT Y
