- 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