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