Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: WVPURP

WVPURP.m

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