APCLP15.m

APCLP15 ; IHS/BJI/GRL - Routine to create bulletin  [ 10/27/03  9:27 AM ]

 ;;3.0;IHS PCC REPORTS;**15**;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

POST ;EP

OPT ;add new options

 NEW X

 S X=$$ADD^XPDMENU("APCL M MAN QUALITY ASSURANCE","APCL P REFUSAL LIST","REF")

 I 'X W "Attempt to add PATIENT REFUSAL LIST report option failed.." H 3

 S X=$$DELETE^XPDMENU("APCL M MAN APC REPORTS/PCC","APCL P APC DX")

 D ^APCLP151

 ;;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","V3P15",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

APCLP15   ; IHS/BJI/GRL - Routine to create bulletin  [ 10/27/03  9:27 AM ]

 +1       ;;3.0;IHS PCC REPORTS;**15**;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 

POST      ;EP

OPT       ;add new options

 +1        NEW X

 +2        SET X=$$ADD^XPDMENU("APCL M MAN QUALITY ASSURANCE","APCL P REFUSAL LIST","REF")

 +3        IF 'X

               WRITE "Attempt to add PATIENT REFUSAL LIST report option failed.."

               HANG 3

 +4        SET X=$$DELETE^XPDMENU("APCL M MAN APC REPORTS/PCC","APCL P APC DX")

 +5        DO ^APCLP151

 +6       ;;Here's how to make this work:

 +7       ;;

 +8       ;;1. Create your message in subroutine WRITEMSG

 +9       ;;2. Identify recipients in GETRECIP by setting APCLKEY

 +10      ;;3. Make changes in SUBJECT and SENDER as desired

 +11      ;;4. Rename this routine in appropriate namespace and 

 +12      ;;   call on completion of patch or upgrade

 +13      ;

 +14       IF '$GET(DUZ)

               WRITE !,"DUZ UNDEFINED OR ZERO.",!

               QUIT 

 +15       DO HOME^%ZIS

           DO DT^DICRW

 +16      ;

 +17       NEW XMSUB,XMDUZ,XMTEXT,XMY,DIFROM

 +18       KILL ^TMP($JOB,"APCLBUL")

 +19       DO WRITEMSG

           DO GETRECIP

 +20      ;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","V3P15",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