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

APCLP13.m

Go to the documentation of this file. 
  1. APCLP13 ; IHS/CMI/LAB - Routine to create bulletin ; [ 05/20/03 10:01 AM ]
  1.  ;;3.0;IHS PCC REPORTS;**13**;FEB 15, 1997
  1.  ;;
  1.  ; The following line prevents the "Disable Options..." and "Move
  1.  ; Routines..." questions from being asked during the install.
  1.  I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
  1.  Q
  1.  ;
  1. PRE ;EP
  1.  F DA=1:1:900 S DIK="^APCLVSTS(" D ^DIK
  1.  ;kill off lister entries
  1.  F DA=1:1:40 S DIK="^APCLRECD(" D ^DIK
  1.  F DA=1:1:4 S DIK="^APCLDMTX(" D ^DIK
  1.  F DA=1:1:40 S DIK="^APCLBMI(" D ^DIK
  1.  K ^APCLBMI("H")
  1.  Q
  1. DRUGS ;set up drug taxonomies
  1.  S ATXFLG=1
  1.  S APCLX="DM AUDIT ANTI-PLATELET DRUGS" D DRUG1
  1.  S APCLX="DM AUDIT STATIN DRUGS" D DRUG1
  1.  Q
  1. DRUG1 ;
  1.  W !,"Creating ",APCLX," Taxonomy..."
  1.  S APCLDA=$O(^ATXAX("B",APCLX,0))
  1.  Q:APCLDA  ;taxonomy already exisits
  1.  S X=APCLX,DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DIADD,DLAYGO,I
  1.  I Y=-1 W !!,"ERROR IN CREATING ",APCLX," TAX" Q
  1.  S APCLTX=+Y,$P(^ATXAX(APCLTX,0),U,2)=APCLX,$P(^(0),U,5)=DUZ,$P(^(0),U,8)=0,$P(^(0),U,9)=DT,$P(^(0),U,12)=173,$P(^(0),U,13)=0,$P(^(0),U,15)=50,^ATXAX(APCLTX,21,0)="^9002226.02101A^0^0"
  1.  S DA=APCLTX,DIK="^ATXAX(" D IX1^DIK
  1.  Q
  1. POST ;EP
  1.  D ^APCLP13A
  1.  D DRUGS
  1.  ;*** REMEMBER TO SEND APCLVSTS GLOBAL AS GLOBAL OR AS KIDS
  1. OPT ;add 2 new options (supplement, report)
  1.  NEW X
  1.  S X=$$ADD^XPDMENU("APCL M MAIN DM MENU","APCL DM2003 AUDIT MENU","DM03",3)
  1.  I 'X W "Attempt to add DM 2003 Audit Menu option failed.." H 3
  1.  S X=$$ADD^XPDMENU("APCLMENU","APCL P QA DELETE REP DEF","RDD")
  1.  I 'X W "Attempt to add delete option for vgen/pgen failed.." H 3
  1.  S X=$$ADD^XPDMENU("APCLMENU","APCL M MAN DELIMITED REPORTS","DELR")
  1.  I 'X W "Attempt to delimited reports menu failed.." H 3
  1.  ;;Here's how to make this work:
  1.  ;;
  1.  ;;1. Create your message in subroutine WRITEMSG
  1.  ;;2. Identify recipients in GETRECIP by setting APCLKEY
  1.  ;;3. Make changes in SUBJECT and SENDER as desired
  1.  ;;4. Rename this routine in appropriate namespace and 
  1.  ;;   call on completion of patch or upgrade
  1.  ;
  1.  I '$G(DUZ) W !,"DUZ UNDEFINED OR ZERO.",! Q
  1.  D HOME^%ZIS,DT^DICRW
  1.  ;
  1.  NEW XMSUB,XMDUZ,XMTEXT,XMY,DIFROM
  1.  KILL ^TMP($J,"APCLBUL")
  1.  D WRITEMSG,GETRECIP
  1.  ;Change following lines as desired
  1. SUBJECT S XMSUB="* * * IMPORTANT RPMS INFORMATION * * *"
  1. SENDER S XMDUZ="Cimarron Medical Informatics"
  1.  S XMTEXT="^TMP($J,""APCLBUL"",",XMY(1)="",XMY(DUZ)=""
  1.  I $E(IOST)="C" W !,"Sending Mailman message to holders of the"_" "_APCLKEY_" "_"security key."
  1.  D ^XMD
  1.  KILL ^TMP($J,"APCLBUL"),APCLKEY
  1.  Q
  1.  ;
  1. WRITEMSG ;
  1.  S X=$O(^APCLPDES("B","V3P13",0))
  1.  Q:'X
  1.  S Y=0 F  S Y=$O(^APCLPDES(X,11,Y)) Q:Y'=+Y  S ^TMP($J,"APCLBUL",Y)=^APCLPDES(X,11,Y,0)
  1.  Q
  1.  ;
  1. GETRECIP ;
  1.  ;* * * Define key below to identify recipients * * *
  1.  ;
  1.  S CTR=0,APCLKEY="APCLZMENU"
  1.  F  S CTR=$O(^XUSEC(APCLKEY,CTR)) Q:'CTR  S Y=CTR S XMY(Y)=""
  1.  Q