- 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
