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

BGP50P1.m

Go to the documentation of this file.
  1. BGP50P1 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 20 Dec 2004 9:23 AM ;
  1. ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
  1. ;
  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 BGPX=1:1:2000 S DA=BGPX,DIK="^BGPINDVC(" D ^DIK
  1. F BGPX=1:1:50 S DA=BGPX,DIK="^BGPINDV(" D ^DIK
  1. F BGPX=1:1:250 S DA=BGPX,DIK="^BGPVNPL(" D ^DIK
  1. F BGPX=1:1:10 S DA=BGPX,DIK="^BGPCTRL(" D ^DIK
  1. S DIU=90371.04,DIU(0)="" D EN^DIU2
  1. S DIU=90371.03,DIU(0)="" D EN^DIU2
  1. S DIU=90371.05,DIU(0)="" D EN^DIU2
  1. Q
  1. POST ;EP - called from kids build
  1. D SEC
  1. D BULL
  1. D ^BGPTXH
  1. Q
  1. SEC ;set security on selected dd's
  1. LP ;EP - loop through file entries
  1. F I=1:1 D Q:BGPTXT["end"
  1. .S BGPTXT=$T(TXT+I)
  1. .Q:BGPTXT["end"
  1. .F J=2:1:4 S BGP(J)=$P(BGPTXT,";;",J)
  1. .S BGP(3)=""""_BGP(3)_""""
  1. .S BGPREF="^DIC("_BGP(2)_",0,"_BGP(3)_")"
  1. .S @BGPREF=BGP(4)
  1. Q
  1. TXT ;file entries start here
  1. ;;90244.01;;AUDIT;;@
  1. ;;90244.01;;DD;;@
  1. ;;90244.01;;DEL;;@
  1. ;;90244.01;;LAYGO;;@
  1. ;;90244.01;;RD;;M
  1. ;;90244.01;;WR;;@
  1. ;;90244.02;;AUDIT;;@
  1. ;;90244.02;;DD;;@
  1. ;;90244.02;;DEL;;@
  1. ;;90244.02;;LAYGO;;@
  1. ;;90244.02;;RD;;M
  1. ;;90244.02;;WR;;@
  1. ;;90371.03;;AUDIT;;@
  1. ;;90371.03;;DD;;@
  1. ;;90371.03;;DEL;;@
  1. ;;90371.03;;LAYGO;;M
  1. ;;90371.03;;RD;;M
  1. ;;90371.03;;WR;;M
  1. ;;90371.04;;AUDIT;;@
  1. ;;90371.04;;DD;;@
  1. ;;90371.04;;DEL;;@
  1. ;;90371.04;;LAYGO;;M
  1. ;;90371.04;;RD;;M
  1. ;;90371.04;;WR;;M
  1. ;;90371.05;;AUDIT;;@
  1. ;;90371.05;;DD;;@
  1. ;;90371.05;;DEL;;@
  1. ;;90371.05;;LAYGO;;M
  1. ;;90371.05;;RD;;M
  1. ;;90371.05;;WR;;M
  1. ;;90372.03;;AUDIT;;@
  1. ;;90372.03;;DD;;@
  1. ;;90372.03;;DEL;;M
  1. ;;90372.03;;LAYGO;;M
  1. ;;90372.03;;RD;;M
  1. ;;90372.03;;WR;;M
  1. ;;90372.05;;AUDIT;;@
  1. ;;90372.05;;DD;;@
  1. ;;90372.05;;DEL;;M
  1. ;;90372.05;;LAYGO;;M
  1. ;;90372.05;;RD;;M
  1. ;;90372.05;;WR;;M
  1. ;;end
  1. Q
  1. BULL ;bulletin wth updates
  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,"BGPBUL")
  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,""BGPBUL"",",XMY(1)="",XMY(DUZ)=""
  1. I $E(IOST)="C" W !,"Sending Mailman message to holders of the"_" "_BGPKEY_" "_"security key."
  1. D ^XMD
  1. KILL ^TMP($J,"BGPBUL"),BGPKEY
  1. Q
  1. ;
  1. WRITEMSG ;
  1. S BGPIEN=$O(^BGPCTRL("B","2005",0))
  1. I BGPIEN="" W !!,"couldn't find bulletin text" Q
  1. S Y=0,%=0 F S Y=$O(^BGPCTRL(BGPIEN,98,1,11,Y)) Q:Y'=+Y S X=$G(^BGPCTRL(BGPIEN,98,1,11,Y,0)) S %=%+1,^TMP($J,"BGPBUL",%)=X
  1. Q
  1. GETRECIP ;
  1. ;* * * Define key below to identify recipients * * *
  1. ;
  1. S CTR=0,BGPKEY="BGPZMENU"
  1. F S CTR=$O(^XUSEC(BGPKEY,CTR)) Q:'CTR S Y=CTR S XMY(Y)=""
  1. Q