APCLP20 ; IHS/BJI/GRL - Routine to create bulletin [ 01/16/05 2:03 PM ]
;;3.0;IHS PCC REPORTS;**19**;FEB 05, 1997
;;
; The following line prevents the "Disable Options..." and "Move
; Routines..." questions from being asked during the install.
F X="XPO1","XPZ1","XPZ2","XPI1" S XPDDIQ(X)=0
I '$$INSTALLD("ATX*5.1*8") D SORRY(2)
I '$$INSTALLD("APCL*3.0*19") D SORRY(2)
;I '$$INSTALLD("AMQQ*2.0*20") D SORRY(2)
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:10 S DIK="^APCLDMTX(" D ^DIK
F DA=1:1:40 S DIK="^APCLBMI(" D ^DIK
F DA=1:1:40 S DIK="^APCLCNTL(" D ^DIK
F DA=1:1:20 S DIK="^APCLPDES(" D ^DIK
K ^APCLBMI("H")
S DA=$O(^DIC(19,"B","APCL DM2005 RUN AUDIT",0)) I DA S DIE="^DIC(19,",DR="2///@" D ^DIE K DIE,DA,DR
Q
POST ;EP
OPT ;add new options
S X=$$DELETE^XPDMENU("APCL M MAN APC REPORTS/PCC","APCL P APC DX CATEGORY")
S X=$$DELETE^XPDMENU("APCL M DX/PROC COUNT REPORTS","APCL P QA POVAPC")
S X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL P INTERNET ACCESS","PINT")
I 'X W "Attempt to add Internet access report option failed.." H 3
;
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","V3P20",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
INSTALLD(APCLSTAL) ;EP - Determine if patch APCLSTAL was installed, where
; APCLSTAL is the name of the INSTALL. E.g "AG*6.0*11".
;
NEW APCLY,DIC,X,Y
S X=$P(APCLSTAL,"*",1)
S DIC="^DIC(9.4,",DIC(0)="FM",D="C"
D IX^DIC
I Y<1 D IMES Q 0
S DIC=DIC_+Y_",22,",X=$P(APCLSTAL,"*",2)
D ^DIC
I Y<1 D IMES Q 0
S DIC=DIC_+Y_",""PAH"",",X=$P(APCLSTAL,"*",3)
D ^DIC
S APCLY=Y
D IMES
Q $S(APCLY<1:0,1:1)
IMES ;
D MES^XPDUTL($$CJ^XLFSTR("Patch """_APCLSTAL_""" is"_$S(Y<1:" *NOT*",1:"")_" installed.",IOM))
Q
SORRY(X) ;
KILL DIFQ
I X=3 S XPDQUIT=2 Q
S XPDQUIT=X
W *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
Q
APCLP20 ; IHS/BJI/GRL - Routine to create bulletin [ 01/16/05 2:03 PM ]
+1 ;;3.0;IHS PCC REPORTS;**19**;FEB 05, 1997
+2 ;;
+3 ; The following line prevents the "Disable Options..." and "Move
+4 ; Routines..." questions from being asked during the install.
+5 FOR X="XPO1","XPZ1","XPZ2","XPI1"
SET XPDDIQ(X)=0
+6 IF '$$INSTALLD("ATX*5.1*8")
DO SORRY(2)
+7 IF '$$INSTALLD("APCL*3.0*19")
DO SORRY(2)
+8 ;I '$$INSTALLD("AMQQ*2.0*20") D SORRY(2)
+9 QUIT
+10 ;
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:10
SET DIK="^APCLDMTX("
DO ^DIK
+5 FOR DA=1:1:40
SET DIK="^APCLBMI("
DO ^DIK
+6 FOR DA=1:1:40
SET DIK="^APCLCNTL("
DO ^DIK
+7 FOR DA=1:1:20
SET DIK="^APCLPDES("
DO ^DIK
+8 KILL ^APCLBMI("H")
+9 SET DA=$ORDER(^DIC(19,"B","APCL DM2005 RUN AUDIT",0))
IF DA
SET DIE="^DIC(19,"
SET DR="2///@"
DO ^DIE
KILL DIE,DA,DR
+10 QUIT
POST ;EP
OPT ;add new options
+1 SET X=$$DELETE^XPDMENU("APCL M MAN APC REPORTS/PCC","APCL P APC DX CATEGORY")
+2 SET X=$$DELETE^XPDMENU("APCL M DX/PROC COUNT REPORTS","APCL P QA POVAPC")
+3 SET X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL P INTERNET ACCESS","PINT")
+4 IF 'X
WRITE "Attempt to add Internet access report option failed.."
HANG 3
+5 ;
+6 DO HOME^%ZIS
DO DT^DICRW
+7 ;
+8 NEW XMSUB,XMDUZ,XMTEXT,XMY,DIFROM
+9 KILL ^TMP($JOB,"APCLBUL")
+10 DO WRITEMSG
DO GETRECIP
+11 ;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","V3P20",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
INSTALLD(APCLSTAL) ;EP - Determine if patch APCLSTAL was installed, where
+1 ; APCLSTAL is the name of the INSTALL. E.g "AG*6.0*11".
+2 ;
+3 NEW APCLY,DIC,X,Y
+4 SET X=$PIECE(APCLSTAL,"*",1)
+5 SET DIC="^DIC(9.4,"
SET DIC(0)="FM"
SET D="C"
+6 DO IX^DIC
+7 IF Y<1
DO IMES
QUIT 0
+8 SET DIC=DIC_+Y_",22,"
SET X=$PIECE(APCLSTAL,"*",2)
+9 DO ^DIC
+10 IF Y<1
DO IMES
QUIT 0
+11 SET DIC=DIC_+Y_",""PAH"","
SET X=$PIECE(APCLSTAL,"*",3)
+12 DO ^DIC
+13 SET APCLY=Y
+14 DO IMES
+15 QUIT $SELECT(APCLY<1:0,1:1)
IMES ;
+1 DO MES^XPDUTL($$CJ^XLFSTR("Patch """_APCLSTAL_""" is"_$SELECT(Y<1:" *NOT*",1:"")_" installed.",IOM))
+2 QUIT
SORRY(X) ;
+1 KILL DIFQ
+2 IF X=3
SET XPDQUIT=2
QUIT
+3 SET XPDQUIT=X
+4 WRITE *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
+5 QUIT
