BGP50P1 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 20 Dec 2004 9:23 AM ;
;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
;
;
; The following line prevents the "Disable Options..." and "Move
; Routines..." questions from being asked during the install.
I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
Q
;
PRE ;EP
F BGPX=1:1:2000 S DA=BGPX,DIK="^BGPINDVC(" D ^DIK
F BGPX=1:1:50 S DA=BGPX,DIK="^BGPINDV(" D ^DIK
F BGPX=1:1:250 S DA=BGPX,DIK="^BGPVNPL(" D ^DIK
F BGPX=1:1:10 S DA=BGPX,DIK="^BGPCTRL(" D ^DIK
S DIU=90371.04,DIU(0)="" D EN^DIU2
S DIU=90371.03,DIU(0)="" D EN^DIU2
S DIU=90371.05,DIU(0)="" D EN^DIU2
Q
POST ;EP - called from kids build
D SEC
D BULL
D ^BGPTXH
Q
SEC ;set security on selected dd's
LP ;EP - loop through file entries
F I=1:1 D Q:BGPTXT["end"
.S BGPTXT=$T(TXT+I)
.Q:BGPTXT["end"
.F J=2:1:4 S BGP(J)=$P(BGPTXT,";;",J)
.S BGP(3)=""""_BGP(3)_""""
.S BGPREF="^DIC("_BGP(2)_",0,"_BGP(3)_")"
.S @BGPREF=BGP(4)
Q
TXT ;file entries start here
;;90244.01;;AUDIT;;@
;;90244.01;;DD;;@
;;90244.01;;DEL;;@
;;90244.01;;LAYGO;;@
;;90244.01;;RD;;M
;;90244.01;;WR;;@
;;90244.02;;AUDIT;;@
;;90244.02;;DD;;@
;;90244.02;;DEL;;@
;;90244.02;;LAYGO;;@
;;90244.02;;RD;;M
;;90244.02;;WR;;@
;;90371.03;;AUDIT;;@
;;90371.03;;DD;;@
;;90371.03;;DEL;;@
;;90371.03;;LAYGO;;M
;;90371.03;;RD;;M
;;90371.03;;WR;;M
;;90371.04;;AUDIT;;@
;;90371.04;;DD;;@
;;90371.04;;DEL;;@
;;90371.04;;LAYGO;;M
;;90371.04;;RD;;M
;;90371.04;;WR;;M
;;90371.05;;AUDIT;;@
;;90371.05;;DD;;@
;;90371.05;;DEL;;@
;;90371.05;;LAYGO;;M
;;90371.05;;RD;;M
;;90371.05;;WR;;M
;;90372.03;;AUDIT;;@
;;90372.03;;DD;;@
;;90372.03;;DEL;;M
;;90372.03;;LAYGO;;M
;;90372.03;;RD;;M
;;90372.03;;WR;;M
;;90372.05;;AUDIT;;@
;;90372.05;;DD;;@
;;90372.05;;DEL;;M
;;90372.05;;LAYGO;;M
;;90372.05;;RD;;M
;;90372.05;;WR;;M
;;end
Q
BULL ;bulletin wth updates
I '$G(DUZ) W !,"DUZ UNDEFINED OR ZERO.",! Q
D HOME^%ZIS,DT^DICRW
;
NEW XMSUB,XMDUZ,XMTEXT,XMY,DIFROM
KILL ^TMP($J,"BGPBUL")
D WRITEMSG,GETRECIP
;Change following lines as desired
SUBJECT S XMSUB="* * * IMPORTANT RPMS INFORMATION * * *"
SENDER S XMDUZ="Cimarron Medical Informatics"
S XMTEXT="^TMP($J,""BGPBUL"",",XMY(1)="",XMY(DUZ)=""
I $E(IOST)="C" W !,"Sending Mailman message to holders of the"_" "_BGPKEY_" "_"security key."
D ^XMD
KILL ^TMP($J,"BGPBUL"),BGPKEY
Q
;
WRITEMSG ;
S BGPIEN=$O(^BGPCTRL("B","2005",0))
I BGPIEN="" W !!,"couldn't find bulletin text" Q
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
Q
GETRECIP ;
;* * * Define key below to identify recipients * * *
;
S CTR=0,BGPKEY="BGPZMENU"
F S CTR=$O(^XUSEC(BGPKEY,CTR)) Q:'CTR S Y=CTR S XMY(Y)=""
Q
BGP50P1 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 20 Dec 2004 9:23 AM ;
+1 ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
+2 ;
+3 ;
+4 ; The following line prevents the "Disable Options..." and "Move
+5 ; Routines..." questions from being asked during the install.
+6 IF $GET(XPDENV)=1
SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
+7 QUIT
+8 ;
PRE ;EP
+1 FOR BGPX=1:1:2000
SET DA=BGPX
SET DIK="^BGPINDVC("
DO ^DIK
+2 FOR BGPX=1:1:50
SET DA=BGPX
SET DIK="^BGPINDV("
DO ^DIK
+3 FOR BGPX=1:1:250
SET DA=BGPX
SET DIK="^BGPVNPL("
DO ^DIK
+4 FOR BGPX=1:1:10
SET DA=BGPX
SET DIK="^BGPCTRL("
DO ^DIK
+5 SET DIU=90371.04
SET DIU(0)=""
DO EN^DIU2
+6 SET DIU=90371.03
SET DIU(0)=""
DO EN^DIU2
+7 SET DIU=90371.05
SET DIU(0)=""
DO EN^DIU2
+8 QUIT
POST ;EP - called from kids build
+1 DO SEC
+2 DO BULL
+3 DO ^BGPTXH
+4 QUIT
SEC ;set security on selected dd's
LP ;EP - loop through file entries
+1 FOR I=1:1
Begin DoDot:1
+2 SET BGPTXT=$TEXT(TXT+I)
+3 IF BGPTXT["end"
QUIT
+4 FOR J=2:1:4
SET BGP(J)=$PIECE(BGPTXT,";;",J)
+5 SET BGP(3)=""""_BGP(3)_""""
+6 SET BGPREF="^DIC("_BGP(2)_",0,"_BGP(3)_")"
+7 SET @BGPREF=BGP(4)
End DoDot:1
IF BGPTXT["end"
QUIT
+8 QUIT
TXT ;file entries start here
+1 ;;90244.01;;AUDIT;;@
+2 ;;90244.01;;DD;;@
+3 ;;90244.01;;DEL;;@
+4 ;;90244.01;;LAYGO;;@
+5 ;;90244.01;;RD;;M
+6 ;;90244.01;;WR;;@
+7 ;;90244.02;;AUDIT;;@
+8 ;;90244.02;;DD;;@
+9 ;;90244.02;;DEL;;@
+10 ;;90244.02;;LAYGO;;@
+11 ;;90244.02;;RD;;M
+12 ;;90244.02;;WR;;@
+13 ;;90371.03;;AUDIT;;@
+14 ;;90371.03;;DD;;@
+15 ;;90371.03;;DEL;;@
+16 ;;90371.03;;LAYGO;;M
+17 ;;90371.03;;RD;;M
+18 ;;90371.03;;WR;;M
+19 ;;90371.04;;AUDIT;;@
+20 ;;90371.04;;DD;;@
+21 ;;90371.04;;DEL;;@
+22 ;;90371.04;;LAYGO;;M
+23 ;;90371.04;;RD;;M
+24 ;;90371.04;;WR;;M
+25 ;;90371.05;;AUDIT;;@
+26 ;;90371.05;;DD;;@
+27 ;;90371.05;;DEL;;@
+28 ;;90371.05;;LAYGO;;M
+29 ;;90371.05;;RD;;M
+30 ;;90371.05;;WR;;M
+31 ;;90372.03;;AUDIT;;@
+32 ;;90372.03;;DD;;@
+33 ;;90372.03;;DEL;;M
+34 ;;90372.03;;LAYGO;;M
+35 ;;90372.03;;RD;;M
+36 ;;90372.03;;WR;;M
+37 ;;90372.05;;AUDIT;;@
+38 ;;90372.05;;DD;;@
+39 ;;90372.05;;DEL;;M
+40 ;;90372.05;;LAYGO;;M
+41 ;;90372.05;;RD;;M
+42 ;;90372.05;;WR;;M
+43 ;;end
+44 QUIT
BULL ;bulletin wth updates
+1 IF '$GET(DUZ)
WRITE !,"DUZ UNDEFINED OR ZERO.",!
QUIT
+2 DO HOME^%ZIS
DO DT^DICRW
+3 ;
+4 NEW XMSUB,XMDUZ,XMTEXT,XMY,DIFROM
+5 KILL ^TMP($JOB,"BGPBUL")
+6 DO WRITEMSG
DO GETRECIP
+7 ;Change following lines as desired
SUBJECT SET XMSUB="* * * IMPORTANT RPMS INFORMATION * * *"
SENDER SET XMDUZ="Cimarron Medical Informatics"
+1 SET XMTEXT="^TMP($J,""BGPBUL"","
SET XMY(1)=""
SET XMY(DUZ)=""
+2 IF $EXTRACT(IOST)="C"
WRITE !,"Sending Mailman message to holders of the"_" "_BGPKEY_" "_"security key."
+3 DO ^XMD
+4 KILL ^TMP($JOB,"BGPBUL"),BGPKEY
+5 QUIT
+6 ;
WRITEMSG ;
+1 SET BGPIEN=$ORDER(^BGPCTRL("B","2005",0))
+2 IF BGPIEN=""
WRITE !!,"couldn't find bulletin text"
QUIT
+3 SET Y=0
SET %=0
FOR
SET Y=$ORDER(^BGPCTRL(BGPIEN,98,1,11,Y))
IF Y'=+Y
QUIT
SET X=$GET(^BGPCTRL(BGPIEN,98,1,11,Y,0))
SET %=%+1
SET ^TMP($JOB,"BGPBUL",%)=X
+4 QUIT
GETRECIP ;
+1 ;* * * Define key below to identify recipients * * *
+2 ;
+3 SET CTR=0
SET BGPKEY="BGPZMENU"
+4 FOR
SET CTR=$ORDER(^XUSEC(BGPKEY,CTR))
IF 'CTR
QUIT
SET Y=CTR
SET XMY(Y)=""
+5 QUIT
