- WVUTL1A ;HCIOFO/JR,FT - Continuation of ^WVUTL1 (Utilities) ;07/20/2015 11:12
- ;;1.0;WOMEN'S HEALTH;**4,7,14,24**;Sep 30, 1998;Build 582
- ;
- ; This routine uses the following IAs:
- ; #1252 - $$OUTPTPR^SDUTL3 (supported)
- ; #2483 - FILE 2, Field 1901 (private)
- ; #2716 - $$GETSTAT^DGMSTAPI (supported)
- ; #10035 - ^DPT(DFN,.104 (supported)
- ; #10060 - FILE 200 fields (supported)
- ; #10090 - FILE 4 fields (supported)
- ;
- PRIOR() ;EP
- ;---> CALLED FROM WV NOTIF-EDITBLK-1 TO GET VALUE AND TEXT OF
- ;---> NOTIFICATION PRIORITY AND RESULT/REMINDER, FROM PURPOSE OF
- ;---> NOTIFICATION WHEN FIRST DISPLAYING SCREEN.
- ;---> REQUIRED VARIABLE: DA=IEN OF NOTIFICATION.
- N X
- Q:'$D(DA) "UNKNOWN"
- Q:'$D(^WV(790.4,DA,0)) "UNKNOWN"
- S X=$P(^WV(790.4,DA,0),U,4)
- Q:'X "UNKNOWN"
- Q $$PRIOR1
- ;
- PRIOR1() ;EP
- ;---> CALLED FROM WV NOTIF-EDITBLK-1 TO GET VALUE AND TEXT OF
- ;---> NOTIFICATION PRIORITY FROM PURPOSE OF NOTIFICATION AS AN
- ;---> ACTION WHEN EDITING PURPOSE OF NOTIFICATION. ALSO DISPLAY
- ;---> WHETHER PURPOSE IS A RESULT OR A REMINDER.
- ;---> REQUIRED VARIABLE: X=IEN IN NOTIFICATION PURPOSE FILE.
- N R,Y,Z
- Q:'$D(X) "UNDEFINED"
- Q:'X "UNKNOWN"
- Q:'$D(^WV(790.404,X,0)) "UNKNOWN"
- S Y=$P(^WV(790.404,X,0),U,2) D
- .I 'Y S R="UNKNOWN" Q
- .I '$$VFIELD^DILFD(790.404,.02) S R="^DD MISSING"
- .S R=$$EXTERNAL^DILFD(790.404,.02,"",Y)
- S Z=$P(^WV(790.404,X,0),U,6)
- Q:Z="" R
- Q:Z R_", RESULT"
- Q R_", REMINDER"
- ;
- ;
- NTPROC() ;EP
- ;---> CALLED FROM WV NOTIF-EDITBLK-1(?) BLOCK TO DISPLAY PROCEDURE
- ;---> NAME, BASED ON ACCESSION# PTR, WHEN FIRST DISPLAYING SCREEN.
- ;---> REQUIRED VARIABLE: X=ACCESSION# OF PROCEDURE
- N X
- S X=$P(^WV(790.4,DA,0),U,6)
- Q $$PROC
- ;
- PROC() ;EP
- ;---> DISPLAY PROCEDURE TYPE OF THIS PROCEDURE.
- ;---> REQUIRED VARIABLE: X=IEN OF PROCEDURE IN PROC FILE #790.1.
- N WVY,WVYY,Y,Z S WVYY="INVALID ACC# OR PTR"
- Q:X']"" ""
- Q:'$D(^WV(790.1,X,0)) WVYY
- S WVY=$P(^WV(790.1,X,0),U,4)
- Q:'WVY WVYY
- Q:'$D(^WV(790.2,WVY,0)) WVYY
- S Z=$P(^WV(790.2,WVY,0),U)
- ;---> IF UNILATERAL AND LEFT/RIGHT HAS A VALUE, REPLACE "UNILATERAL"
- ;---> WITH LEFT OR RIGHT.
- S Y=$P(^WV(790.1,X,0),U,9)
- S Y=$S(Y="l":"LEFT",Y="r":"RIGHT",1:"")
- Q:Y="" Z
- Q $P(Z," ")_" "_Y
- ;
- PROC1() ;EP
- ;---> DISPLAY PROCEDURE TYPE OF THIS PROCEDURE, USING DA.
- ;---> CALLED BY WV PROC-HEADER-1, WHICH CANNOT USE X.
- ;---> REQUIRED VARIABLE: DA=IEN OF PROCEDURE IN PROC FILE #790.1.
- N X S X=DA
- Q $$PROC
- PROVI(DFN) ;
- ;---> RETURNS THE PRIMARY CARE PROVIDER
- ;---> REQUIRED VARIABLE: DFN
- Q:$G(DFN)'>0 "UNKNOWN"
- N X S X=$P($G(^DPT(DFN,.104)),U)
- S X=$S(X>0:$$GET1^DIQ(200,X,.01,"E"),1:"")
- I X="" S X=$P($$OUTPTPR^SDUTL3(DFN),U,2)
- S:X="" X="UNKNOWN"
- Q X
- SCR(X) ;
- Q:$G(X)'>0 0
- S WVJX=$S(X>0:$P($G(^WV(790.07,X,0)),U,2),1:0)
- Q WVJX
- QUAD(X) ;
- Q:$TR(X,"ULR,")'="" 0
- N TEST,CN,CNT,WVJX S WVJX=X,CN=""
- S (CN("LL"),CN("UL"),CN("UR"),CN("LR"))="",TEST=1
- F S CN=$O(CN(CN)) Q:CN="" I $P(WVJX,CN,2,5)[CN S WVJX=$P(WVJX,CN,1,2)_$P(WVJX,CN,3)
- F CN=1:1:11 I $E(WVJX,CN)=","&($E(WVJX,CN+1)=",") S WVJX=$E(WVJX,1,CN)_$E(WVJX,CN+2,11) S CN=CN-1
- F CN=1:1:4 S CNT=$P(X,",",CN) I CNT'="" I '$D(CN(CNT)) S TEST=0 Q
- S:$E(WVJX,$L(WVJX))="," WVJX=$E(WVJX,1,$L(WVJX)-1)
- S:$E(WVJX,1)="," WVJX=$E(WVJX,2,11)
- S:TEST>0 TEST=TEST_"^"_WVJX
- Q TEST
- REF ;
- N X,Y,B,L
- Q:$G(DA)="" S X=DA
- S Y=X,X=$P($G(^WV(790.07,X,0)),U)
- S L="abcdefghijklmnopqrstuvwxyz"
- S B="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
- S X=$TR($E(X,1,$L(X)),L,B)
- I WVACT="SET" S ^WV(790.07,"C",X,Y)=""
- I WVACT="KIL" K ^WV(790.07,"C",X,Y)
- K WVACT Q
- FAC N X,Y
- S WVJBFAC="",WVJCFAC="",WVJPCP=""
- Q:$G(WVDFN)'>0
- S X=$G(^WV(790,WVDFN,0))
- S WVJBFAC=$P(X,U,25),WVJCFAC=$P(X,U,26),WVJPCP=$$PROVI(WVDFN)
- S:WVJBFAC>0 WVJBFAC=$E($$GET1^DIQ(4,WVJBFAC,.01,"E"),1,18)
- S:WVJCFAC>0 WVJCFAC=$E($$GET1^DIQ(4,WVJCFAC,.01,"E"),1,18)
- Q
- RAXS(DA) ;
- N WVJJ0
- I $G(DA)'>0 Q 0
- S WVJJ0=$G(^WV(790.1,DA,0))
- I '$D(WVJJ0) Q 0
- I "^BU^MB^MU^MS^"'[$E(WVJJ0,1,2) Q 0
- I $P(WVJJ0,U,15)="" Q 0
- Q 1
- FACIL(DFN,TYP) ;Gets Treatment Facility, if typ="C" for Cervix, "B" for Breast
- N X,Y
- S Y=""
- I $G(DFN)'>0 Q Y
- S X=$G(^WV(790,DFN,0))
- S:TYP="B" Y=$P(X,U,25) S:TYP="C" Y=$P(X,U,26)
- S:Y>0 Y=$E($$GET1^DIQ(4,Y,.01,"E"),1,18)
- Q Y
- MST(WVDFN) ;Gets Military Sexual Trauma
- I $G(WVDFN)'>0 Q ""
- N X,WVMST
- S WVMST=$$GETSTAT^DGMSTAPI(WVDFN)
- S WVMST=$S($P(WVMST,U,6)]"":$P(WVMST,U,6),1:"")
- S:WVMST="" WVMST="Unknown, not screened"
- I $E($$VET(WVDFN))'="Y" S WVMST="<N/A Not a Veteran>"
- Q WVMST
- ;
- SC(WVJ,WVFN) ;Screen called from File 790.02 to elim. inactive from selectable
- I $G(XQY0)["WV ADD/EDIT CASE MANAGERS" Q 1
- I $G(WVJOPEN)>0 Q 1
- N WVINACT
- S WVINACT=$P($G(^WV(WVFN,+WVJ,0)),U,2) ;date inactivated
- I WVINACT>0,WVINACT<$G(DT) Q 0
- Q 1
- LOOK(WVJ) ;Display select fields with lookup on 790, not file#2 Identif.
- Q:WVJ'>0
- N DIC,DA,DR,DIQ,Y
- S DIC="^WV(790,",DA=WVJ,DIQ="WVJAR(",DIQ(0)="E"
- S DR=".06;.1;.16" D EN^DIQ1
- S WVJ=WVJAR(790,WVJ,.06,"E")_" "_WVJAR(790,WVJ,.1,"E")
- K WVJAR
- Q WVJ
- LOOKL(WVJ) ;
- N Y,WVX,WVP,WVY,WVDT,WVP,X,WVDTS,WVMARK,X1,X2
- S X1=DT,X2=-30 D C^%DTC S WVDTS=X
- S WVX="" F S WVX=$O(^WV(790.3,"C",+WVJ,WVX)) Q:WVX'>0 D
- .S WVY=$G(^WV(790.3,WVX,0)),WVDT=+WVY,WVP=$P(WVY,U,3)
- .Q:WVDT'>WVDTS S WVMARK=1
- .S Y=WVDT D DD^%DT S WVDT=Y
- .;S WVP=$S(WVP'>0:"",1:$P($G(^WV(790.1,WVP,0)),U,4))
- .S:WVP'="" WVP=$P($G(^WV(790.2,WVP,0)),U)
- .W !?32,WVDT,?47,WVP
- W:$G(WVMARK)=1 !
- Q
- RUNDT(WVY) ;Get and format run date for various reports
- ; Center when WVY="C"
- N Y,WVJ,%
- I $D(WVJRNOW) Q WVJRNOW
- D NOW^%DTC S Y=% D DD^%DT
- S Y=$E(Y,1,12)_" "_$E(Y,14,18)
- S:$L(Y)'>10 Y=""
- S (WVJRNOW,WVJ)="Run Date: "_Y
- I $G(WVY)="C" S (WVJ,WVJRNOW)=" "_WVJRNOW
- Q WVJ
- ;
- LINE ; Called from the WV LINE FOR MENUS option. That option is merely a
- ; place holder in the menu and used for visual purposes. This is
- ; entry point does nothing.
- Q
- VET(DFN) ; Check if patient is a veteran.
- N WVETERAN
- S WVETERAN=$$GET1^DIQ(2,DFN,1901,"I")
- Q $S(WVETERAN="Y":"Yes",WVETERAN="N":"No",1:"Unknown")
- ;
- CST(WVDFN) ; Return Civilian Sexual Trauma value
- Q $$GET1^DIQ(790,+WVDFN,.28,"E")
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVUTL1A 6238 printed Feb 19, 2025@00:14:38 Page 2
- WVUTL1A ;HCIOFO/JR,FT - Continuation of ^WVUTL1 (Utilities) ;07/20/2015 11:12
- +1 ;;1.0;WOMEN'S HEALTH;**4,7,14,24**;Sep 30, 1998;Build 582
- +2 ;
- +3 ; This routine uses the following IAs:
- +4 ; #1252 - $$OUTPTPR^SDUTL3 (supported)
- +5 ; #2483 - FILE 2, Field 1901 (private)
- +6 ; #2716 - $$GETSTAT^DGMSTAPI (supported)
- +7 ; #10035 - ^DPT(DFN,.104 (supported)
- +8 ; #10060 - FILE 200 fields (supported)
- +9 ; #10090 - FILE 4 fields (supported)
- +10 ;
- PRIOR() ;EP
- +1 ;---> CALLED FROM WV NOTIF-EDITBLK-1 TO GET VALUE AND TEXT OF
- +2 ;---> NOTIFICATION PRIORITY AND RESULT/REMINDER, FROM PURPOSE OF
- +3 ;---> NOTIFICATION WHEN FIRST DISPLAYING SCREEN.
- +4 ;---> REQUIRED VARIABLE: DA=IEN OF NOTIFICATION.
- +5 NEW X
- +6 if '$DATA(DA)
- QUIT "UNKNOWN"
- +7 if '$DATA(^WV(790.4,DA,0))
- QUIT "UNKNOWN"
- +8 SET X=$PIECE(^WV(790.4,DA,0),U,4)
- +9 if 'X
- QUIT "UNKNOWN"
- +10 QUIT $$PRIOR1
- +11 ;
- PRIOR1() ;EP
- +1 ;---> CALLED FROM WV NOTIF-EDITBLK-1 TO GET VALUE AND TEXT OF
- +2 ;---> NOTIFICATION PRIORITY FROM PURPOSE OF NOTIFICATION AS AN
- +3 ;---> ACTION WHEN EDITING PURPOSE OF NOTIFICATION. ALSO DISPLAY
- +4 ;---> WHETHER PURPOSE IS A RESULT OR A REMINDER.
- +5 ;---> REQUIRED VARIABLE: X=IEN IN NOTIFICATION PURPOSE FILE.
- +6 NEW R,Y,Z
- +7 if '$DATA(X)
- QUIT "UNDEFINED"
- +8 if 'X
- QUIT "UNKNOWN"
- +9 if '$DATA(^WV(790.404,X,0))
- QUIT "UNKNOWN"
- +10 SET Y=$PIECE(^WV(790.404,X,0),U,2)
- Begin DoDot:1
- +11 IF 'Y
- SET R="UNKNOWN"
- QUIT
- +12 IF '$$VFIELD^DILFD(790.404,.02)
- SET R="^DD MISSING"
- +13 SET R=$$EXTERNAL^DILFD(790.404,.02,"",Y)
- End DoDot:1
- +14 SET Z=$PIECE(^WV(790.404,X,0),U,6)
- +15 if Z=""
- QUIT R
- +16 if Z
- QUIT R_", RESULT"
- +17 QUIT R_", REMINDER"
- +18 ;
- +19 ;
- NTPROC() ;EP
- +1 ;---> CALLED FROM WV NOTIF-EDITBLK-1(?) BLOCK TO DISPLAY PROCEDURE
- +2 ;---> NAME, BASED ON ACCESSION# PTR, WHEN FIRST DISPLAYING SCREEN.
- +3 ;---> REQUIRED VARIABLE: X=ACCESSION# OF PROCEDURE
- +4 NEW X
- +5 SET X=$PIECE(^WV(790.4,DA,0),U,6)
- +6 QUIT $$PROC
- +7 ;
- PROC() ;EP
- +1 ;---> DISPLAY PROCEDURE TYPE OF THIS PROCEDURE.
- +2 ;---> REQUIRED VARIABLE: X=IEN OF PROCEDURE IN PROC FILE #790.1.
- +3 NEW WVY,WVYY,Y,Z
- SET WVYY="INVALID ACC# OR PTR"
- +4 if X']""
- QUIT ""
- +5 if '$DATA(^WV(790.1,X,0))
- QUIT WVYY
- +6 SET WVY=$PIECE(^WV(790.1,X,0),U,4)
- +7 if 'WVY
- QUIT WVYY
- +8 if '$DATA(^WV(790.2,WVY,0))
- QUIT WVYY
- +9 SET Z=$PIECE(^WV(790.2,WVY,0),U)
- +10 ;---> IF UNILATERAL AND LEFT/RIGHT HAS A VALUE, REPLACE "UNILATERAL"
- +11 ;---> WITH LEFT OR RIGHT.
- +12 SET Y=$PIECE(^WV(790.1,X,0),U,9)
- +13 SET Y=$SELECT(Y="l":"LEFT",Y="r":"RIGHT",1:"")
- +14 if Y=""
- QUIT Z
- +15 QUIT $PIECE(Z," ")_" "_Y
- +16 ;
- PROC1() ;EP
- +1 ;---> DISPLAY PROCEDURE TYPE OF THIS PROCEDURE, USING DA.
- +2 ;---> CALLED BY WV PROC-HEADER-1, WHICH CANNOT USE X.
- +3 ;---> REQUIRED VARIABLE: DA=IEN OF PROCEDURE IN PROC FILE #790.1.
- +4 NEW X
- SET X=DA
- +5 QUIT $$PROC
- PROVI(DFN) ;
- +1 ;---> RETURNS THE PRIMARY CARE PROVIDER
- +2 ;---> REQUIRED VARIABLE: DFN
- +3 if $GET(DFN)'>0
- QUIT "UNKNOWN"
- +4 NEW X
- SET X=$PIECE($GET(^DPT(DFN,.104)),U)
- +5 SET X=$SELECT(X>0:$$GET1^DIQ(200,X,.01,"E"),1:"")
- +6 IF X=""
- SET X=$PIECE($$OUTPTPR^SDUTL3(DFN),U,2)
- +7 if X=""
- SET X="UNKNOWN"
- +8 QUIT X
- SCR(X) ;
- +1 if $GET(X)'>0
- QUIT 0
- +2 SET WVJX=$SELECT(X>0:$PIECE($GET(^WV(790.07,X,0)),U,2),1:0)
- +3 QUIT WVJX
- QUAD(X) ;
- +1 if $TRANSLATE(X,"ULR,")'=""
- QUIT 0
- +2 NEW TEST,CN,CNT,WVJX
- SET WVJX=X
- SET CN=""
- +3 SET (CN("LL"),CN("UL"),CN("UR"),CN("LR"))=""
- SET TEST=1
- +4 FOR
- SET CN=$ORDER(CN(CN))
- if CN=""
- QUIT
- IF $PIECE(WVJX,CN,2,5)[CN
- SET WVJX=$PIECE(WVJX,CN,1,2)_$PIECE(WVJX,CN,3)
- +5 FOR CN=1:1:11
- IF $EXTRACT(WVJX,CN)=","&($EXTRACT(WVJX,CN+1)=",")
- SET WVJX=$EXTRACT(WVJX,1,CN)_$EXTRACT(WVJX,CN+2,11)
- SET CN=CN-1
- +6 FOR CN=1:1:4
- SET CNT=$PIECE(X,",",CN)
- IF CNT'=""
- IF '$DATA(CN(CNT))
- SET TEST=0
- QUIT
- +7 if $EXTRACT(WVJX,$LENGTH(WVJX))=","
- SET WVJX=$EXTRACT(WVJX,1,$LENGTH(WVJX)-1)
- +8 if $EXTRACT(WVJX,1)=","
- SET WVJX=$EXTRACT(WVJX,2,11)
- +9 if TEST>0
- SET TEST=TEST_"^"_WVJX
- +10 QUIT TEST
- REF ;
- +1 NEW X,Y,B,L
- +2 if $GET(DA)=""
- QUIT
- SET X=DA
- +3 SET Y=X
- SET X=$PIECE($GET(^WV(790.07,X,0)),U)
- +4 SET L="abcdefghijklmnopqrstuvwxyz"
- +5 SET B="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
- +6 SET X=$TRANSLATE($EXTRACT(X,1,$LENGTH(X)),L,B)
- +7 IF WVACT="SET"
- SET ^WV(790.07,"C",X,Y)=""
- +8 IF WVACT="KIL"
- KILL ^WV(790.07,"C",X,Y)
- +9 KILL WVACT
- QUIT
- FAC NEW X,Y
- +1 SET WVJBFAC=""
- SET WVJCFAC=""
- SET WVJPCP=""
- +2 if $GET(WVDFN)'>0
- QUIT
- +3 SET X=$GET(^WV(790,WVDFN,0))
- +4 SET WVJBFAC=$PIECE(X,U,25)
- SET WVJCFAC=$PIECE(X,U,26)
- SET WVJPCP=$$PROVI(WVDFN)
- +5 if WVJBFAC>0
- SET WVJBFAC=$EXTRACT($$GET1^DIQ(4,WVJBFAC,.01,"E"),1,18)
- +6 if WVJCFAC>0
- SET WVJCFAC=$EXTRACT($$GET1^DIQ(4,WVJCFAC,.01,"E"),1,18)
- +7 QUIT
- RAXS(DA) ;
- +1 NEW WVJJ0
- +2 IF $GET(DA)'>0
- QUIT 0
- +3 SET WVJJ0=$GET(^WV(790.1,DA,0))
- +4 IF '$DATA(WVJJ0)
- QUIT 0
- +5 IF "^BU^MB^MU^MS^"'[$EXTRACT(WVJJ0,1,2)
- QUIT 0
- +6 IF $PIECE(WVJJ0,U,15)=""
- QUIT 0
- +7 QUIT 1
- FACIL(DFN,TYP) ;Gets Treatment Facility, if typ="C" for Cervix, "B" for Breast
- +1 NEW X,Y
- +2 SET Y=""
- +3 IF $GET(DFN)'>0
- QUIT Y
- +4 SET X=$GET(^WV(790,DFN,0))
- +5 if TYP="B"
- SET Y=$PIECE(X,U,25)
- if TYP="C"
- SET Y=$PIECE(X,U,26)
- +6 if Y>0
- SET Y=$EXTRACT($$GET1^DIQ(4,Y,.01,"E"),1,18)
- +7 QUIT Y
- MST(WVDFN) ;Gets Military Sexual Trauma
- +1 IF $GET(WVDFN)'>0
- QUIT ""
- +2 NEW X,WVMST
- +3 SET WVMST=$$GETSTAT^DGMSTAPI(WVDFN)
- +4 SET WVMST=$SELECT($PIECE(WVMST,U,6)]"":$PIECE(WVMST,U,6),1:"")
- +5 if WVMST=""
- SET WVMST="Unknown, not screened"
- +6 IF $EXTRACT($$VET(WVDFN))'="Y"
- SET WVMST="<N/A Not a Veteran>"
- +7 QUIT WVMST
- +8 ;
- SC(WVJ,WVFN) ;Screen called from File 790.02 to elim. inactive from selectable
- +1 IF $GET(XQY0)["WV ADD/EDIT CASE MANAGERS"
- QUIT 1
- +2 IF $GET(WVJOPEN)>0
- QUIT 1
- +3 NEW WVINACT
- +4 ;date inactivated
- SET WVINACT=$PIECE($GET(^WV(WVFN,+WVJ,0)),U,2)
- +5 IF WVINACT>0
- IF WVINACT<$GET(DT)
- QUIT 0
- +6 QUIT 1
- LOOK(WVJ) ;Display select fields with lookup on 790, not file#2 Identif.
- +1 if WVJ'>0
- QUIT
- +2 NEW DIC,DA,DR,DIQ,Y
- +3 SET DIC="^WV(790,"
- SET DA=WVJ
- SET DIQ="WVJAR("
- SET DIQ(0)="E"
- +4 SET DR=".06;.1;.16"
- DO EN^DIQ1
- +5 SET WVJ=WVJAR(790,WVJ,.06,"E")_" "_WVJAR(790,WVJ,.1,"E")
- +6 KILL WVJAR
- +7 QUIT WVJ
- LOOKL(WVJ) ;
- +1 NEW Y,WVX,WVP,WVY,WVDT,WVP,X,WVDTS,WVMARK,X1,X2
- +2 SET X1=DT
- SET X2=-30
- DO C^%DTC
- SET WVDTS=X
- +3 SET WVX=""
- FOR
- SET WVX=$ORDER(^WV(790.3,"C",+WVJ,WVX))
- if WVX'>0
- QUIT
- Begin DoDot:1
- +4 SET WVY=$GET(^WV(790.3,WVX,0))
- SET WVDT=+WVY
- SET WVP=$PIECE(WVY,U,3)
- +5 if WVDT'>WVDTS
- QUIT
- SET WVMARK=1
- +6 SET Y=WVDT
- DO DD^%DT
- SET WVDT=Y
- +7 ;S WVP=$S(WVP'>0:"",1:$P($G(^WV(790.1,WVP,0)),U,4))
- +8 if WVP'=""
- SET WVP=$PIECE($GET(^WV(790.2,WVP,0)),U)
- +9 WRITE !?32,WVDT,?47,WVP
- End DoDot:1
- +10 if $GET(WVMARK)=1
- WRITE !
- +11 QUIT
- RUNDT(WVY) ;Get and format run date for various reports
- +1 ; Center when WVY="C"
- +2 NEW Y,WVJ,%
- +3 IF $DATA(WVJRNOW)
- QUIT WVJRNOW
- +4 DO NOW^%DTC
- SET Y=%
- DO DD^%DT
- +5 SET Y=$EXTRACT(Y,1,12)_" "_$EXTRACT(Y,14,18)
- +6 if $LENGTH(Y)'>10
- SET Y=""
- +7 SET (WVJRNOW,WVJ)="Run Date: "_Y
- +8 IF $GET(WVY)="C"
- SET (WVJ,WVJRNOW)=" "_WVJRNOW
- +9 QUIT WVJ
- +10 ;
- LINE ; Called from the WV LINE FOR MENUS option. That option is merely a
- +1 ; place holder in the menu and used for visual purposes. This is
- +2 ; entry point does nothing.
- +3 QUIT
- VET(DFN) ; Check if patient is a veteran.
- +1 NEW WVETERAN
- +2 SET WVETERAN=$$GET1^DIQ(2,DFN,1901,"I")
- +3 QUIT $SELECT(WVETERAN="Y":"Yes",WVETERAN="N":"No",1:"Unknown")
- +4 ;
- CST(WVDFN) ; Return Civilian Sexual Trauma value
- +1 QUIT $$GET1^DIQ(790,+WVDFN,.28,"E")
- +2 ;
