WVPURP ;HIOFO/FT,JR-NOTIFICATION TABLES MAINTENANC; ;8/28/03 16:38
;;1.0;WOMEN'S HEALTH;**4,9,16**;Sep 30, 1998
;; Original routine created by IHS/ANMC/MWR
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; ADD/EDIT/PRINT NOTIFICATION PURPOSE FILE ENTRIES, EDIT PCD DAYS,
;; EDIT NOTIFICATION TYPE SYNONYMS, ADD/EDIT NOTIFICATION OUTCOMES.
;
; This routine uses the following IAs:
; #10089 - ^%ZISC call (supported)
; #10103 - ^XLFDT calls (supported)
; #10104 - ^XLFSTR calls (supported)
;
PRINTPUR ; Called by option "WV PRINT NOTIF PURPOSE&LETTER"
D SETVARS^WVUTL5
D DEVICE
I WVPOP D KILL Q
PRINT ; Print purpose and letter entries
U IO
S WVNAME="",(WVPAGE,WVPOP)=0
S WVDATE=$$FMTE^XLFDT($$NOW^XLFDT(),"1P") ;current date/time
S WVDASH=$$REPEAT^XLFSTR("-",79) ;line of dashes
; loop thru File 790.404 (B x-ref)
F S WVNAME=$O(^WV(790.404,"B",WVNAME)) Q:WVNAME=""!(WVPOP) S WVIEN=0 F S WVIEN=$O(^WV(790.404,"B",WVNAME,WVIEN)) Q:'WVIEN!(WVPOP) D
.S WVNODE=$G(^WV(790.404,WVIEN,0)) Q:WVNODE=""
.D HEADER
.D RESOLVE
.W !!?3,"PURPOSE: "_$P(WVNODE,U,1),?55,"SYNONYM: "_$P(WVNODE,U,3)
.W !?2,"PRIORITY: "_$G(WVARRAY(790.404,WVIEN_",",.02,"E")),?56,"ACTIVE: "_$G(WVARRAY(790.404,WVIEN_",",.04,"E"))
.W !?2,"BR or CX: "_$G(WVARRAY(790.404,WVIEN_",",.05,"E"))
.W !?4,"LETTER: "_$G(WVARRAY(790.404,WVIEN_",",.06,"E"))
.W !,"BR TX NEED: "_$G(WVARRAY(790.404,WVIEN_",",.07,"E"))
.S WVDUE=$$DMY($G(WVARRAY(790.404,WVIEN_",",.08,"E")))
.W ?48,"BR TX DUE DATE: "_WVDUE
.W !,"CX TX NEED: "_$G(WVARRAY(790.404,WVIEN_",",.09,"E"))
.S WVDUE=$$DMY($G(WVARRAY(790.404,WVIEN_",",.1,"E")))
.W ?48,"CX TX DUE DATE: "_WVDUE,!!
.S WVLINE=0
.F S WVLINE=$O(^WV(790.404,WVIEN,1,WVLINE)) Q:'WVLINE!(WVPOP) D
..I ($Y+4)>IOSL D:$E(IOST)="C" DIRZ^WVUTL3 Q:WVPOP D HEADER
..W !,$G(^WV(790.404,WVIEN,1,WVLINE,0))
..Q
.Q:WVPOP
.I $E(IOST)="C" D DIRZ^WVUTL3
.Q
I $D(ZTQUEUED) S ZTREQ="@"
KILL ; Kill variables
K WVARRAY,WVDASH,WVDATE,WVDUE,WVIEN,WVLINE
K WVNAME,WVNODE,WVPAGE,WVPOP,X,Y
D ^%ZISC
Q
W:$Y>0 @IOF
S WVPAGE=WVPAGE+1
W "NOTIFICATION PURPOSE & LETTER LIST",?45,WVDATE,?70,"PAGE: "_WVPAGE
W !,WVDASH
Q
RESOLVE ; Resolve data to external values
K WVARRAY
D CLEAN^DILF
D GETS^DIQ(790.404,WVIEN_",",".02;.04:.1","E","WVARRAY")
Q
DEVICE ; Get device and possibly queue to taskman
N ZTRTN
S ZTRTN="DEQUEUE^WVPURP"
D ZIS^WVUTL2(.WVPOP,1,"HOME")
Q
DEQUEUE ; Taskman queue of printout
D PRINT
Q
;
EDITPUR ;EP
;---> CALLED BY OPTION "WV EDIT NOTIF PURPOSE&LETTER".
D SETVARS^WVUTL5
;---> DISPLAY MENU TITLE FROM WV MENU OPTIONS.
F D Q:$G(Y)<0
.D TITLE^WVUTL5("EDIT NOTIFICATION PURPOSE & LETTER FILE")
.D DIC^WVFMAN(790.404,"QEMAL",.Y)
.Q:Y<0
.S DA=+Y
.D:$P(Y,U,3) ADDLET
.D:'$P(Y,U,3) REPLACE
.Q:WVPOP
.;---> EDIT WITH SCREENMAN.
.S DR="[WV NOTIFPURPOSE-FORM-1]"
.D DDS^WVFMAN(790.404,DR,DA,"","",.WVPOP)
D KILLALL^WVUTL8
Q
;
;
ADDLET ;EP
;---> CALLED BY OPTION "WV ADD NOTIF PURPOSE&LETTER".
K ^WV(790.404,DA,1)
N N 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
;
REPLACE ;EP
;---> REPLACE OLD LETTER FOR THIS NOTIF PURPOSE WITH GENERIC SAMPLE.
N DIR,DIRUT,Y
W !!?3,"Do you wish to delete the old letter for this Purpose of "
W "Notification",!?3,"and replace it with the generic sample letter?"
S DIR(0)="YA",DIR("B")="NO"
S DIR("A")=" Enter Yes or No: " D HELP1
D ^DIR W !
S:$D(DIRUT) WVPOP=1
I Y D ADDLET
Q
;
HELP1 ;EP
;;Enter YES to delete the old letter for this Purpose of Notification
;;and to begin with a fresh copy of the generic sample letter.
S WVTAB=5,WVLINL="HELP1" D HELPTX
Q
;
HELPTX ;EP
N I,T,X S T=$$REPEAT^XLFSTR(" ",WVTAB)
F I=1:1 S X=$T(@WVLINL+I) Q:X'[";;" S DIR("?",I)=T_$P(X,";;",2)
S DIR("?")=DIR("?",I-1) K DIR("?",I-1)
Q
;
TYPE ;EP
;---> EDIT SYNONYMS FOR NOTIFICATION TYPES.
D SETVARS^WVUTL5
F D Q:$G(Y)<0
.D TITLE^WVUTL5("EDIT SYNONYMS FOR NOTIFICATION TYPES") D TEXT1
.N A S A=" Select NOTIFICATION TYPE: "
.D DIC^WVFMAN(790.403,"QEMA",.Y,A)
.Q:Y<0
.D DIE^WVFMAN(790.403,.03,+Y,.WVPOP)
W @IOF
D KILLALL^WVUTL8
Q
;
OUTCOME ;EP
;---> ADD/EDIT NOTIFICATION OUTCOME FILE.
D SETVARS^WVUTL5
F D Q:$G(Y)<0
.D TITLE^WVUTL5("ADD/EDIT NOTIFICATION OUTCOME FILE")
.D DIC^WVFMAN(790.405,"QEMAL",.Y," Select OUTCOME: ")
.Q:Y<0
.D DIE^WVFMAN(790.405,.02,+Y,.WVPOP)
W @IOF
D KILLALL^WVUTL8
Q
;
TEXT1 ;EP
;;You may enter a synonym for each Notification Type. The synonym will
;;allow the Notification Type to be called up by typing only a few
;;characters. Synonyms should be unique and less than 4 characters.
;;
;;For example, "L1" might be used for LETTER,FIRST; "L2" for
;;LETTER,SECOND; "L3" for LETTER,THIRD, and so on.
;;
;;
S WVTAB=5,WVLINL="TEXT1" D PRINTX
Q
;
PRINTX ;EP
N I,T,X S T=$$REPEAT^XLFSTR(" ",WVTAB)
F I=1:1 S X=$T(@WVLINL+I) Q:X'[";;" W !,T,$P(X,";;",2)
Q
;
GENSTUFF ;EP
;---> STUFF THE GENERIC SAMPLE LETTER INTO ALL PURPOSES OF NOTIF.
N DA
S DA=0
F S DA=$O(^WV(790.404,DA)) Q:'DA W !,DA D ADDLET^WVPURP
Q
DMY(WVDUE) ; Spell out Days, Months or Years
N WVDUE1,WVDUE2
I WVDUE="" Q ""
I '$S(WVDUE["D":1,WVDUE["M":1,WVDUE["Y":1,1:0) Q WVDUE
S WVDUE1=+WVDUE
S WVDUE2=$S(WVDUE["D":"Day",WVDUE["M":"Month",WVDUE["Y":"Year",1:"")
S:WVDUE1>1 WVDUE2=WVDUE2_"s"
S:WVDUE2="s" WVDUE2=""
S WVDUE=WVDUE1_" "_WVDUE2
Q WVDUE
;
DMYCHECK ; Called from ^DD(790.404,.8,0) - BR TX DUE DATE
; and ^DD(790.404,.1,0) - CX TX DUE DATE
; Check X to see if it is a date offset (e.g., 365D, 12M or 1Y).
; Returns -1 if not an exceptable value
Q:'$D(X)
I $L(X)>4!($L(X)<2) S X=-1 Q
S X=$$UP^XLFSTR(X)
I X'?1.3N1"D",X'?1.3N1"M",X'?1.3N1"Y" S X=-1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVPURP 5974 printed Sep 23, 2025@20:23:49 Page 2
WVPURP ;HIOFO/FT,JR-NOTIFICATION TABLES MAINTENANC; ;8/28/03 16:38
+1 ;;1.0;WOMEN'S HEALTH;**4,9,16**;Sep 30, 1998
+2 ;; Original routine created by IHS/ANMC/MWR
+3 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+4 ;; ADD/EDIT/PRINT NOTIFICATION PURPOSE FILE ENTRIES, EDIT PCD DAYS,
+5 ;; EDIT NOTIFICATION TYPE SYNONYMS, ADD/EDIT NOTIFICATION OUTCOMES.
+6 ;
+7 ; This routine uses the following IAs:
+8 ; #10089 - ^%ZISC call (supported)
+9 ; #10103 - ^XLFDT calls (supported)
+10 ; #10104 - ^XLFSTR calls (supported)
+11 ;
PRINTPUR ; Called by option "WV PRINT NOTIF PURPOSE&LETTER"
+1 DO SETVARS^WVUTL5
+2 DO DEVICE
+3 IF WVPOP
DO KILL
QUIT
PRINT ; Print purpose and letter entries
+1 USE IO
+2 SET WVNAME=""
SET (WVPAGE,WVPOP)=0
+3 ;current date/time
SET WVDATE=$$FMTE^XLFDT($$NOW^XLFDT(),"1P")
+4 ;line of dashes
SET WVDASH=$$REPEAT^XLFSTR("-",79)
+5 ; loop thru File 790.404 (B x-ref)
+6 FOR
SET WVNAME=$ORDER(^WV(790.404,"B",WVNAME))
if WVNAME=""!(WVPOP)
QUIT
SET WVIEN=0
FOR
SET WVIEN=$ORDER(^WV(790.404,"B",WVNAME,WVIEN))
if 'WVIEN!(WVPOP)
QUIT
Begin DoDot:1
+7 SET WVNODE=$GET(^WV(790.404,WVIEN,0))
if WVNODE=""
QUIT
+8 DO HEADER
+9 DO RESOLVE
+10 WRITE !!?3,"PURPOSE: "_$PIECE(WVNODE,U,1),?55,"SYNONYM: "_$PIECE(WVNODE,U,3)
+11 WRITE !?2,"PRIORITY: "_$GET(WVARRAY(790.404,WVIEN_",",.02,"E")),?56,"ACTIVE: "_$GET(WVARRAY(790.404,WVIEN_",",.04,"E"))
+12 WRITE !?2,"BR or CX: "_$GET(WVARRAY(790.404,WVIEN_",",.05,"E"))
+13 WRITE !?4,"LETTER: "_$GET(WVARRAY(790.404,WVIEN_",",.06,"E"))
+14 WRITE !,"BR TX NEED: "_$GET(WVARRAY(790.404,WVIEN_",",.07,"E"))
+15 SET WVDUE=$$DMY($GET(WVARRAY(790.404,WVIEN_",",.08,"E")))
+16 WRITE ?48,"BR TX DUE DATE: "_WVDUE
+17 WRITE !,"CX TX NEED: "_$GET(WVARRAY(790.404,WVIEN_",",.09,"E"))
+18 SET WVDUE=$$DMY($GET(WVARRAY(790.404,WVIEN_",",.1,"E")))
+19 WRITE ?48,"CX TX DUE DATE: "_WVDUE,!!
+20 SET WVLINE=0
+21 FOR
SET WVLINE=$ORDER(^WV(790.404,WVIEN,1,WVLINE))
if 'WVLINE!(WVPOP)
QUIT
Begin DoDot:2
+22 IF ($Y+4)>IOSL
if $EXTRACT(IOST)="C"
DO DIRZ^WVUTL3
if WVPOP
QUIT
DO HEADER
+23 WRITE !,$GET(^WV(790.404,WVIEN,1,WVLINE,0))
+24 QUIT
End DoDot:2
+25 if WVPOP
QUIT
+26 IF $EXTRACT(IOST)="C"
DO DIRZ^WVUTL3
+27 QUIT
End DoDot:1
+28 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL ; Kill variables
+1 KILL WVARRAY,WVDASH,WVDATE,WVDUE,WVIEN,WVLINE
+2 KILL WVNAME,WVNODE,WVPAGE,WVPOP,X,Y
+3 DO ^%ZISC
+4 QUIT
+1 if $Y>0
WRITE @IOF
+2 SET WVPAGE=WVPAGE+1
+3 WRITE "NOTIFICATION PURPOSE & LETTER LIST",?45,WVDATE,?70,"PAGE: "_WVPAGE
+4 WRITE !,WVDASH
+5 QUIT
RESOLVE ; Resolve data to external values
+1 KILL WVARRAY
+2 DO CLEAN^DILF
+3 DO GETS^DIQ(790.404,WVIEN_",",".02;.04:.1","E","WVARRAY")
+4 QUIT
DEVICE ; Get device and possibly queue to taskman
+1 NEW ZTRTN
+2 SET ZTRTN="DEQUEUE^WVPURP"
+3 DO ZIS^WVUTL2(.WVPOP,1,"HOME")
+4 QUIT
DEQUEUE ; Taskman queue of printout
+1 DO PRINT
+2 QUIT
+3 ;
EDITPUR ;EP
+1 ;---> CALLED BY OPTION "WV EDIT NOTIF PURPOSE&LETTER".
+2 DO SETVARS^WVUTL5
+3 ;---> DISPLAY MENU TITLE FROM WV MENU OPTIONS.
+4 FOR
Begin DoDot:1
+5 DO TITLE^WVUTL5("EDIT NOTIFICATION PURPOSE & LETTER FILE")
+6 DO DIC^WVFMAN(790.404,"QEMAL",.Y)
+7 if Y<0
QUIT
+8 SET DA=+Y
+9 if $PIECE(Y,U,3)
DO ADDLET
+10 if '$PIECE(Y,U,3)
DO REPLACE
+11 if WVPOP
QUIT
+12 ;---> EDIT WITH SCREENMAN.
+13 SET DR="[WV NOTIFPURPOSE-FORM-1]"
+14 DO DDS^WVFMAN(790.404,DR,DA,"","",.WVPOP)
End DoDot:1
if $GET(Y)<0
QUIT
+15 DO KILLALL^WVUTL8
+16 QUIT
+17 ;
+18 ;
ADDLET ;EP
+1 ;---> CALLED BY OPTION "WV ADD NOTIF PURPOSE&LETTER".
+2 KILL ^WV(790.404,DA,1)
+3 NEW N
SET N=0
+4 FOR
SET N=$ORDER(^WV(790.6,1,1,N))
if 'N
QUIT
Begin DoDot:1
+5 SET ^WV(790.404,DA,1,N,0)=^WV(790.6,1,1,N,0)
End DoDot:1
+6 SET ^WV(790.404,DA,1,0)=^WV(790.6,1,1,0)
+7 QUIT
+8 ;
REPLACE ;EP
+1 ;---> REPLACE OLD LETTER FOR THIS NOTIF PURPOSE WITH GENERIC SAMPLE.
+2 NEW DIR,DIRUT,Y
+3 WRITE !!?3,"Do you wish to delete the old letter for this Purpose of "
+4 WRITE "Notification",!?3,"and replace it with the generic sample letter?"
+5 SET DIR(0)="YA"
SET DIR("B")="NO"
+6 SET DIR("A")=" Enter Yes or No: "
DO HELP1
+7 DO ^DIR
WRITE !
+8 if $DATA(DIRUT)
SET WVPOP=1
+9 IF Y
DO ADDLET
+10 QUIT
+11 ;
HELP1 ;EP
+1 ;;Enter YES to delete the old letter for this Purpose of Notification
+2 ;;and to begin with a fresh copy of the generic sample letter.
+3 SET WVTAB=5
SET WVLINL="HELP1"
DO HELPTX
+4 QUIT
+5 ;
HELPTX ;EP
+1 NEW I,T,X
SET T=$$REPEAT^XLFSTR(" ",WVTAB)
+2 FOR I=1:1
SET X=$TEXT(@WVLINL+I)
if X'[";;"
QUIT
SET DIR("?",I)=T_$PIECE(X,";;",2)
+3 SET DIR("?")=DIR("?",I-1)
KILL DIR("?",I-1)
+4 QUIT
+5 ;
TYPE ;EP
+1 ;---> EDIT SYNONYMS FOR NOTIFICATION TYPES.
+2 DO SETVARS^WVUTL5
+3 FOR
Begin DoDot:1
+4 DO TITLE^WVUTL5("EDIT SYNONYMS FOR NOTIFICATION TYPES")
DO TEXT1
+5 NEW A
SET A=" Select NOTIFICATION TYPE: "
+6 DO DIC^WVFMAN(790.403,"QEMA",.Y,A)
+7 if Y<0
QUIT
+8 DO DIE^WVFMAN(790.403,.03,+Y,.WVPOP)
End DoDot:1
if $GET(Y)<0
QUIT
+9 WRITE @IOF
+10 DO KILLALL^WVUTL8
+11 QUIT
+12 ;
OUTCOME ;EP
+1 ;---> ADD/EDIT NOTIFICATION OUTCOME FILE.
+2 DO SETVARS^WVUTL5
+3 FOR
Begin DoDot:1
+4 DO TITLE^WVUTL5("ADD/EDIT NOTIFICATION OUTCOME FILE")
+5 DO DIC^WVFMAN(790.405,"QEMAL",.Y," Select OUTCOME: ")
+6 if Y<0
QUIT
+7 DO DIE^WVFMAN(790.405,.02,+Y,.WVPOP)
End DoDot:1
if $GET(Y)<0
QUIT
+8 WRITE @IOF
+9 DO KILLALL^WVUTL8
+10 QUIT
+11 ;
TEXT1 ;EP
+1 ;;You may enter a synonym for each Notification Type. The synonym will
+2 ;;allow the Notification Type to be called up by typing only a few
+3 ;;characters. Synonyms should be unique and less than 4 characters.
+4 ;;
+5 ;;For example, "L1" might be used for LETTER,FIRST; "L2" for
+6 ;;LETTER,SECOND; "L3" for LETTER,THIRD, and so on.
+7 ;;
+8 ;;
+9 SET WVTAB=5
SET WVLINL="TEXT1"
DO PRINTX
+10 QUIT
+11 ;
PRINTX ;EP
+1 NEW I,T,X
SET T=$$REPEAT^XLFSTR(" ",WVTAB)
+2 FOR I=1:1
SET X=$TEXT(@WVLINL+I)
if X'[";;"
QUIT
WRITE !,T,$PIECE(X,";;",2)
+3 QUIT
+4 ;
GENSTUFF ;EP
+1 ;---> STUFF THE GENERIC SAMPLE LETTER INTO ALL PURPOSES OF NOTIF.
+2 NEW DA
+3 SET DA=0
+4 FOR
SET DA=$ORDER(^WV(790.404,DA))
if 'DA
QUIT
WRITE !,DA
DO ADDLET^WVPURP
+5 QUIT
DMY(WVDUE) ; Spell out Days, Months or Years
+1 NEW WVDUE1,WVDUE2
+2 IF WVDUE=""
QUIT ""
+3 IF '$SELECT(WVDUE["D":1,WVDUE["M":1,WVDUE["Y":1,1:0)
QUIT WVDUE
+4 SET WVDUE1=+WVDUE
+5 SET WVDUE2=$SELECT(WVDUE["D":"Day",WVDUE["M":"Month",WVDUE["Y":"Year",1:"")
+6 if WVDUE1>1
SET WVDUE2=WVDUE2_"s"
+7 if WVDUE2="s"
SET WVDUE2=""
+8 SET WVDUE=WVDUE1_" "_WVDUE2
+9 QUIT WVDUE
+10 ;
DMYCHECK ; Called from ^DD(790.404,.8,0) - BR TX DUE DATE
+1 ; and ^DD(790.404,.1,0) - CX TX DUE DATE
+2 ; Check X to see if it is a date offset (e.g., 365D, 12M or 1Y).
+3 ; Returns -1 if not an exceptable value
+4 if '$DATA(X)
QUIT
+5 IF $LENGTH(X)>4!($LENGTH(X)<2)
SET X=-1
QUIT
+6 SET X=$$UP^XLFSTR(X)
+7 IF X'?1.3N1"D"
IF X'?1.3N1"M"
IF X'?1.3N1"Y"
SET X=-1
+8 QUIT
