WVUTL5 ;HCIOFO/FT,JR IHS/ANMC/MWR - UTIL: ACC#, TITLES, SL/TX DATES; ;1/29/99 15:15
;;1.0;WOMEN'S HEALTH;**5**;Sep 30, 1998
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; UTILITY: SETVARS, GENERATE ACCESSION#, MENUT, TITLE, CENTERT,
;; COPYLET, UPPERCASE XREF, SL/TX DATES.
;
;
SETVARS ;EP
S:'$D(WVPOP) WVPOP=0
Q
;**************
;
;
ACCSSN(PCDTYPE) ;EP
;---> GENERATE ACCESSION# FOR WV PROCEDURE FILE ENTRY.
;---> REQUIRED VARIABLE: PCDTYPE=IEN OF PROCEDURE TYPE (#790.2)
N A,C,L,N,P,R,X
Q:'$D(PCDTYPE) ""
Q:'$D(^WV(790.2,PCDTYPE,0)) ""
S X=^WV(790.2,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),1,3)+1700) ;N=YEAR NOW: 94
I A'=N S C=0
F L +^WV(790.2,PCDTYPE,0):1 Q:$T
F S C=C+1 S R=P_N_"-"_C Q:'$D(^WV(790.1,"B",R))
S $P(^WV(790.2,PCDTYPE,0),U,6)=N_"-"_C
L -^WV(790.2,PCDTYPE,0)
Q R ;R=RESULT(NEW ACCESSION#)
;
;---> DISPLAY MENU TITLE FROM WV MENU OPTIONS.
;---> REQUIRED VARIABLES: TITLE=TEXT TO BE CENTERED AND DISPLAYED.
;---> DUZ(2)=CURRENT LOCATION TO BE DISPLAYED.
N WVTTAB,WVFAC
S:'$D(TITLE) TITLE="* NO TITLE SUPPLIED *"
S TITLE="* "_TITLE_" *"
S WVTTAB=39-($L(TITLE)/2)
W @IOF
W !?3,"WOMEN'S HEALTH:"
W ?WVTTAB,TITLE
W ?60,$E($$INSTTX^WVUTL6(DUZ(2)),1,20)
Q
;
TITLE(TITLE) ;EP
;---> DISPLAY A TITLE.
;---> REQUIRED VARIABLES: TITLE=TEXT TO BE CENTERED AND DISPLAYED.
N WVTTAB
S:'$D(TITLE) TITLE="* NO TITLE SUPPLIED *"
S TITLE="* * * WOMEN'S HEALTH: "_TITLE_" * * *"
S WVTTAB=39-($L(TITLE)/2)
W @IOF
W !?WVTTAB,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 WV PURPOSES.
;---> EDIT NEXT LINE TO INCLUDE IENS OF WV PURPOSES TO BE CHANGED.
;F DA=15,16,18,19 D
S DA=0
F S DA=$O(^WV(790.404,DA)) Q:'DA D
.K ^WV(790.404,DA,1)
.S N=0
.F S N=$O(^WV(790.6,1,1,N)) Q:'N D
..S ^WV(790.404,DA,1,N,0)=^WV(790.6,1,1,N,0)
.S ^WV(790.404,DA,1,0)=^WV(790.6,1,1,0)
Q
;
;
UPXREF(X,WVGBL) ;EP
;---> SET UPPERCASE XREF FOR X. CALLED FROM MUMPS XREFS ON MIXED CASE
;---> FIELDS WHERE AN ALL UPPERCASE LOOKUP IS NEEDED.
;---> REQUIRED VARIABLES: WVGBL=GLOBAL ROOT OF FILE, X=TEXT TO BE
;---> CROSSREFERENCED IN ALL UPPERCASE, DA=IEN.
Q:'$D(WVGBL)!('$D(X))
N WVX S WVX=X,X=$$UPPER
S @(WVGBL_"""U"",$E(X,1,30),DA)")=""
S X=WVX K WVGBL
Q
;
KUPXREF(X,WVGBL) ;EP
;---> KILL UPPERCASE XREF FOR X. CALLED FROM MUMPS XREFS ON MIXED CASE
;---> FIELDS WHERE AN ALL UPPERCASE LOOKUP IS NEEDED.
;---> REQUIRED VARIABLES: WVGBL=GLOBAL ROOT OF FILE, X=TEXT TO BE
;---> CROSSREFERENCED IN ALL UPPERCASE, DA=IEN.
Q:'$D(WVGBL)!('$D(X))
N WVX S WVX=X,X=$$UPPER
K @(WVGBL_"""U"",$E(X,1,30),DA)")
S X=WVX K WVGBL
Q
;
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 VA.
Q:'$G(SITE) "v"
Q:'$D(^WV(790.02,SITE,0)) "v"
Q $P(^WV(790.02,SITE,0),U,15)
;
PNLAB() ;EP
;---> RETURN TEXT FOR PATIENT NUMBER: " SSN: ".
Q " SSN: "
;
PNLB() ;EP
;---> RETURN UPPERCASE TEXT FOR PATIENT NUMBER, NO COLON/SPACES.
Q "SSN"
;
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
Q:'$E(DATE,6,7) $E(DATE,4,5)_"/"_$E(DATE,2,3)
Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3)
;
;
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
Q:'$E(DATE,6,7) $E(DATE,4,5)_"/"_$E(DATE,2,3)
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
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVUTL5 4664 printed Oct 16, 2024@18:48:42 Page 2
WVUTL5 ;HCIOFO/FT,JR IHS/ANMC/MWR - UTIL: ACC#, TITLES, SL/TX DATES; ;1/29/99 15:15
+1 ;;1.0;WOMEN'S HEALTH;**5**;Sep 30, 1998
+2 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+3 ;; UTILITY: SETVARS, GENERATE ACCESSION#, MENUT, TITLE, CENTERT,
+4 ;; COPYLET, UPPERCASE XREF, SL/TX DATES.
+5 ;
+6 ;
SETVARS ;EP
+1 if '$DATA(WVPOP)
SET WVPOP=0
+2 QUIT
+3 ;**************
+4 ;
+5 ;
ACCSSN(PCDTYPE) ;EP
+1 ;---> GENERATE ACCESSION# FOR WV PROCEDURE FILE ENTRY.
+2 ;---> REQUIRED VARIABLE: PCDTYPE=IEN OF PROCEDURE TYPE (#790.2)
+3 NEW A,C,L,N,P,R,X
+4 if '$DATA(PCDTYPE)
QUIT ""
+5 if '$DATA(^WV(790.2,PCDTYPE,0))
QUIT ""
+6 ;X=0-NODE OF PROC TYPE
SET X=^WV(790.2,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 DO NOW^%DTC
+12 ;N=YEAR NOW: 94
SET N=($EXTRACT(%I(3),1,3)+1700)
+13 IF A'=N
SET C=0
+14 FOR
LOCK +^WV(790.2,PCDTYPE,0):1
if $TEST
QUIT
+15 FOR
SET C=C+1
SET R=P_N_"-"_C
if '$DATA(^WV(790.1,"B",R))
QUIT
+16 SET $PIECE(^WV(790.2,PCDTYPE,0),U,6)=N_"-"_C
+17 LOCK -^WV(790.2,PCDTYPE,0)
+18 ;R=RESULT(NEW ACCESSION#)
QUIT R
+19 ;
+1 ;---> DISPLAY MENU TITLE FROM WV MENU OPTIONS.
+2 ;---> REQUIRED VARIABLES: TITLE=TEXT TO BE CENTERED AND DISPLAYED.
+3 ;---> DUZ(2)=CURRENT LOCATION TO BE DISPLAYED.
+4 NEW WVTTAB,WVFAC
+5 if '$DATA(TITLE)
SET TITLE="* NO TITLE SUPPLIED *"
+6 SET TITLE="* "_TITLE_" *"
+7 SET WVTTAB=39-($LENGTH(TITLE)/2)
+8 WRITE @IOF
+9 WRITE !?3,"WOMEN'S HEALTH:"
+10 WRITE ?WVTTAB,TITLE
+11 WRITE ?60,$EXTRACT($$INSTTX^WVUTL6(DUZ(2)),1,20)
+12 QUIT
+13 ;
TITLE(TITLE) ;EP
+1 ;---> DISPLAY A TITLE.
+2 ;---> REQUIRED VARIABLES: TITLE=TEXT TO BE CENTERED AND DISPLAYED.
+3 NEW WVTTAB
+4 if '$DATA(TITLE)
SET TITLE="* NO TITLE SUPPLIED *"
+5 SET TITLE="* * * WOMEN'S HEALTH: "_TITLE_" * * *"
+6 SET WVTTAB=39-($LENGTH(TITLE)/2)
+7 WRITE @IOF
+8 WRITE !?WVTTAB,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 WV PURPOSES.
+2 ;---> EDIT NEXT LINE TO INCLUDE IENS OF WV PURPOSES TO BE CHANGED.
+3 ;F DA=15,16,18,19 D
+4 SET DA=0
+5 FOR
SET DA=$ORDER(^WV(790.404,DA))
if 'DA
QUIT
Begin DoDot:1
+6 KILL ^WV(790.404,DA,1)
+7 SET N=0
+8 FOR
SET N=$ORDER(^WV(790.6,1,1,N))
if 'N
QUIT
Begin DoDot:2
+9 SET ^WV(790.404,DA,1,N,0)=^WV(790.6,1,1,N,0)
End DoDot:2
+10 SET ^WV(790.404,DA,1,0)=^WV(790.6,1,1,0)
End DoDot:1
+11 QUIT
+12 ;
+13 ;
UPXREF(X,WVGBL) ;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: WVGBL=GLOBAL ROOT OF FILE, X=TEXT TO BE
+4 ;---> CROSSREFERENCED IN ALL UPPERCASE, DA=IEN.
+5 if '$DATA(WVGBL)!('$DATA(X))
QUIT
+6 NEW WVX
SET WVX=X
SET X=$$UPPER
+7 SET @(WVGBL_"""U"",$E(X,1,30),DA)")=""
+8 SET X=WVX
KILL WVGBL
+9 QUIT
+10 ;
KUPXREF(X,WVGBL) ;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: WVGBL=GLOBAL ROOT OF FILE, X=TEXT TO BE
+4 ;---> CROSSREFERENCED IN ALL UPPERCASE, DA=IEN.
+5 if '$DATA(WVGBL)!('$DATA(X))
QUIT
+6 NEW WVX
SET WVX=X
SET X=$$UPPER
+7 KILL @(WVGBL_"""U"",$E(X,1,30),DA)")
+8 SET X=WVX
KILL WVGBL
+9 QUIT
+10 ;
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 VA.
+4 if '$GET(SITE)
QUIT "v"
+5 if '$DATA(^WV(790.02,SITE,0))
QUIT "v"
+6 QUIT $PIECE(^WV(790.02,SITE,0),U,15)
+7 ;
PNLAB() ;EP
+1 ;---> RETURN TEXT FOR PATIENT NUMBER: " SSN: ".
+2 QUIT " SSN: "
+3 ;
PNLB() ;EP
+1 ;---> RETURN UPPERCASE TEXT FOR PATIENT NUMBER, NO COLON/SPACES.
+2 QUIT "SSN"
+3 ;
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 if '$EXTRACT(DATE,6,7)
QUIT $EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,2,3)
+8 QUIT $EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,6,7)_"/"_$EXTRACT(DATE,2,3)
+9 ;
+10 ;
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 if '$EXTRACT(DATE,6,7)
QUIT $EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,2,3)
+10 DO DD^%DT
if Y["@"
SET Y=" @ "_$PIECE($PIECE(Y,"@",2),":",1,2)
+11 QUIT $EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,6,7)_"/"_$EXTRACT(DATE,2,3)_Y
+12 ;
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
