APCP20P6.m

APCP20P6 ; IHS/TUCSON/LAB - Routine to create bulletin ; [ 08/18/2003   7:44 AM ]

 ;;2.0;IHS PCC DATA EXTRACTION;**6**;APR 03, 1998

 ;;

 ; 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 - pre init

 ;delete all entries from rec file

 S APCPX=0 F  S APCPX=$O(^APCPREC(APCPX)) Q:APCPX'=+APCPX  S DA=APCPX,DIK="^APCPREC(" D ^DIK

 ;data will be reloaded with kids install

 Q

POST ;EP

 ;*** REMEMBER TO SEND APCPVSTS GLOBAL AS GLOBAL OR AS KIDS

OPT ;add 2 new options (supplement, report)

 D LAB ;build lab taxonomy

 NEW X

 S X=$$ADD^XPDMENU("APCPMENU","APCP RE-EXPORT DATE RANGE","EDR")

 I 'X W "Attempt to new re-export option failed.." H 3

 S X=$$DELETE^XPDMENU("APCPMENU","APCP RE-EXPORT MENU")

 S X=$$DELETE^XPDMENU("APCP REPORTS MENU","APCP RPT CHA RECORDS")

 ;;Here's how to make this work:

 ;;

 ;;1. Create your message in subroutine WRITEMSG

 ;;2. Identify recipients in GETRECIP by setting APCPKEY

 ;;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,"APCPBUL")

 D WRITEMSG,GETRECIP

 ;Change following lines as desired

SUBJECT S XMSUB="* * * IMPORTANT RPMS INFORMATION * * *"

SENDER S XMDUZ="Cimarron Medical Informatics"

 S XMTEXT="^TMP($J,""APCPBUL"",",XMY(1)="",XMY(DUZ)=""

 I $E(IOST)="C" W !,"Sending Mailman message to holders of the"_" "_APCPKEY_" "_"security key."

 D ^XMD

 KILL ^TMP($J,"APCPBUL"),APCPKEY

 Q

 ;

WRITEMSG ;

 F %=3:1 S X=$P($T(WRITEMSG+%),";",3) Q:X="###"  S ^TMP($J,"APCPBUL",%)=X

 Q

 ;;  

 ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

 ;;+     This message is intended to advise you of changes,        +

 ;;+     upgrades or other important RPMS information

 ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

 ;;  

 ;;PCC Management Reports Patch 11 has recently been installed.  This patch

 ;;includes the following modifications/enhancements:

 ;;   

 ;;Prevents an Undefined error in various reports if Provider entry

 ;;is missing a discipline code.

 ;;Modifies slightly how BMI is calculated to match other applications

 ;;- Prevents an undef in several reports if provider narrative is blank

 ;;- fixes a problem with activity time report in file 200 converted sites

 ;;- fixed date disply on Calender Year First/Revisit report

 ;;- Adds a check for cpt code 92012 for eye exam in the 2001 audit

 ;;- Modifies the DM Diet Education portion of the 2001 audit to more accurately

 ;;  determine if education was provided by an RD

 ;;- Modifies the 2001 DM Audit to look at Staged Diabetes Managemenent Health

 ;;- Modifies the 2001 DM Audit to look at Diabetes Self Monitoring Health

 ;;- Modifies verbage on BMI reports.

 ;;  factors.

 ;;- Modifies lab lookup on 2001 audit to ignore tests with result COMMENT

 ;;- APCPDF2 - data fetcher - protects against invalid AA xref entries

 ;;- Operations Summary - removes APC recode display because recode table is out

 ;;  of date.

 ;;- Added the ability to save the results of the Overweight/Obese report

 ;;  to a search template

 ;;- NEW REPORTS:

 ;;  - INPC   Inpatient Discharges/Days by Community

 ;;  - INPS   Inpatient Discharges/Days by SU of Residence

 ;;  - INPT   Inpatient Discharges/Days by Tribe

 ;;  - APCP   List Patients on a Register w/an Appointment

 ;;  - HSPrint Health Summary of DM patients w/Appointment

 ;;  - TSCR   Time and Services by Provider for chart reviews

 ;;  - INCV   Listing of Incomplete Lab, Rx or Radiology Visits

 ;;  - UPLP   Upload Patients from text file to search template

 ;;- NEW VGEN/PGEN items

 ;;  - Medicare Part B

 ;;  - Problem List DX (Any)

 ;;  - Problem List DX (Active)

 ;;  - Problem List DX (Inactive)

 ;;  - Hx of Surgery

 ;;  - Most recent Tobacco HF

 ;;  - Most recent TB HF

 ;;  - Most recent SDM HF

 ;;  - Most recent Alcohol HF

 ;;

 ;;For additional information contact your RPMS site manager, Area Office RPMS

 ;;support staff or any of the following Cimarron staff members:

 ;;

 ;;Dorothy Russell *  Gary Lawless    *  Bill Mason       *  Lori Butcher

 ;;(520)-743-3275     (715)-358-3763     (520)-615-0689      (520)-577-2146

 ;;  

 ;;+++++++++++++++++++++ end of announcement +++++++++++++++++++++++

 ;;###

 ;

GETRECIP ;

 ;* * * Define key below to identify recipients * * *

 ;

 S CTR=0,APCPKEY="APCPZMENU"

 F  S CTR=$O(^XUSEC(APCPKEY,CTR)) Q:'CTR  S Y=CTR S XMY(Y)=""

 Q

LAB ;

 S APCPX="APCP PAP SMEAR TESTS" D PAPLAB1

 S APCPX="APCP PSA TESTS TAX" D PSALAB1

 Q

PAPLAB1 ;

 W !,"Creating ",APCPX," Taxonomy..."

 S APCPDA=$O(^ATXLAB("B",APCPX,0))

 Q:APCPDA  ;taxonomy already exisits

 S X=APCPX,DIC="^ATXLAB(",DIC(0)="L",DIADD=1,DLAYGO=9002228 D ^DIC K DIC,DA,DIADD,DLAYGO,I

 I Y=-1 W !!,"ERROR IN CREATING ",APCPX," TAX" Q

 S APCPTX=+Y,$P(^ATXLAB(APCPTX,0),U,2)=APCPX,$P(^(0),U,5)=DUZ,$P(^(0),U,6)=DT,$P(^(0),U,8)="B",$P(^(0),U,9)=60,^ATXLAB(APCPTX,21,0)="^9002228.02101PA^0^0"

 S APCPX=$O(^LAB(60,"B","PAP SMEAR",0))

 I APCPX S ^ATXLAB(APCPTX,21,1,0)=APCPX,^ATXLAB(APCPTX,21,"B",APCPX,1)="",$P(^ATXLAB(APCPTX,21,0),U,3)=APCPX,$P(^ATXLAB(APCPTX,21,0),U,4)=1

 S DA=APCPTX,DIK="^ATXAX(" D IX1^DIK

 Q

 ;

PSALAB1 ;

 W !,"Creating ",APCPX," Taxonomy..."

 S APCPDA=$O(^ATXLAB("B",APCPX,0))

 Q:APCPDA  ;taxonomy already exisits

 S X=APCPX,DIC="^ATXLAB(",DIC(0)="L",DIADD=1,DLAYGO=9002228 D ^DIC K DIC,DA,DIADD,DLAYGO,I

 I Y=-1 W !!,"ERROR IN CREATING ",APCPX," TAX" Q

 S APCPTX=+Y,$P(^ATXLAB(APCPTX,0),U,2)=APCPX,$P(^(0),U,5)=DUZ,$P(^(0),U,6)=DT,$P(^(0),U,8)="B",$P(^(0),U,9)=60,^ATXLAB(APCPTX,21,0)="^9002228.02101PA^0^0"

 S APCPX=$O(^LAB(60,"B","PSA",0))

 I APCPX S ^ATXLAB(APCPTX,21,1,0)=APCPX,^ATXLAB(APCPTX,21,"B",APCPX,1)="",$P(^ATXLAB(APCPTX,21,0),U,3)=APCPX,$P(^ATXLAB(APCPTX,21,0),U,4)=1

 S DA=APCPTX,DIK="^ATXAX(" D IX1^DIK

 Q

 ;

APCP20P6  ; IHS/TUCSON/LAB - Routine to create bulletin ; [ 08/18/2003   7:44 AM ]

 +1       ;;2.0;IHS PCC DATA EXTRACTION;**6**;APR 03, 1998

 +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 - pre init

 +1       ;delete all entries from rec file

 +2        SET APCPX=0

           FOR 

               SET APCPX=$ORDER(^APCPREC(APCPX))

               IF APCPX'=+APCPX

                   QUIT 

               SET DA=APCPX

               SET DIK="^APCPREC("

               DO ^DIK

 +3       ;data will be reloaded with kids install

 +4        QUIT 

POST      ;EP

 +1       ;*** REMEMBER TO SEND APCPVSTS GLOBAL AS GLOBAL OR AS KIDS

OPT       ;add 2 new options (supplement, report)

 +1       ;build lab taxonomy

           DO LAB

 +2        NEW X

 +3        SET X=$$ADD^XPDMENU("APCPMENU","APCP RE-EXPORT DATE RANGE","EDR")

 +4        IF 'X

               WRITE "Attempt to new re-export option failed.."

               HANG 3

 +5        SET X=$$DELETE^XPDMENU("APCPMENU","APCP RE-EXPORT MENU")

 +6        SET X=$$DELETE^XPDMENU("APCP REPORTS MENU","APCP RPT CHA RECORDS")

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

 +8       ;;

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

 +10      ;;2. Identify recipients in GETRECIP by setting APCPKEY

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

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

 +13      ;;   call on completion of patch or upgrade

 +14      ;

 +15       IF '$GET(DUZ)

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

               QUIT 

 +16       DO HOME^%ZIS

           DO DT^DICRW

 +17      ;

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

 +19       KILL ^TMP($JOB,"APCPBUL")

 +20       DO WRITEMSG

           DO GETRECIP

 +21      ;Change following lines as desired

SUBJECT    SET XMSUB="* * * IMPORTANT RPMS INFORMATION * * *"

SENDER     SET XMDUZ="Cimarron Medical Informatics"

 +1        SET XMTEXT="^TMP($J,""APCPBUL"","

           SET XMY(1)=""

           SET XMY(DUZ)=""

 +2        IF $EXTRACT(IOST)="C"

               WRITE !,"Sending Mailman message to holders of the"_" "_APCPKEY_" "_"security key."

 +3        DO ^XMD

 +4        KILL ^TMP($JOB,"APCPBUL"),APCPKEY

 +5        QUIT 

 +6       ;

WRITEMSG  ;

 +1        FOR %=3:1

               SET X=$PIECE($TEXT(WRITEMSG+%),";",3)

               IF X="###"

                   QUIT 

               SET ^TMP($JOB,"APCPBUL",%)=X

 +2        QUIT 

 +3       ;;  

 +4       ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

 +5       ;;+     This message is intended to advise you of changes,        +

 +6       ;;+     upgrades or other important RPMS information

 +7       ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

 +8       ;;  

 +9       ;;PCC Management Reports Patch 11 has recently been installed.  This patch

 +10      ;;includes the following modifications/enhancements:

 +11      ;;   

 +12      ;;Prevents an Undefined error in various reports if Provider entry

 +13      ;;is missing a discipline code.

 +14      ;;Modifies slightly how BMI is calculated to match other applications

 +15      ;;- Prevents an undef in several reports if provider narrative is blank

 +16      ;;- fixes a problem with activity time report in file 200 converted sites

 +17      ;;- fixed date disply on Calender Year First/Revisit report

 +18      ;;- Adds a check for cpt code 92012 for eye exam in the 2001 audit

 +19      ;;- Modifies the DM Diet Education portion of the 2001 audit to more accurately

 +20      ;;  determine if education was provided by an RD

 +21      ;;- Modifies the 2001 DM Audit to look at Staged Diabetes Managemenent Health

 +22      ;;- Modifies the 2001 DM Audit to look at Diabetes Self Monitoring Health

 +23      ;;- Modifies verbage on BMI reports.

 +24      ;;  factors.

 +25      ;;- Modifies lab lookup on 2001 audit to ignore tests with result COMMENT

 +26      ;;- APCPDF2 - data fetcher - protects against invalid AA xref entries

 +27      ;;- Operations Summary - removes APC recode display because recode table is out

 +28      ;;  of date.

 +29      ;;- Added the ability to save the results of the Overweight/Obese report

 +30      ;;  to a search template

 +31      ;;- NEW REPORTS:

 +32      ;;  - INPC   Inpatient Discharges/Days by Community

 +33      ;;  - INPS   Inpatient Discharges/Days by SU of Residence

 +34      ;;  - INPT   Inpatient Discharges/Days by Tribe

 +35      ;;  - APCP   List Patients on a Register w/an Appointment

 +36      ;;  - HSPrint Health Summary of DM patients w/Appointment

 +37      ;;  - TSCR   Time and Services by Provider for chart reviews

 +38      ;;  - INCV   Listing of Incomplete Lab, Rx or Radiology Visits

 +39      ;;  - UPLP   Upload Patients from text file to search template

 +40      ;;- NEW VGEN/PGEN items

 +41      ;;  - Medicare Part B

 +42      ;;  - Problem List DX (Any)

 +43      ;;  - Problem List DX (Active)

 +44      ;;  - Problem List DX (Inactive)

 +45      ;;  - Hx of Surgery

 +46      ;;  - Most recent Tobacco HF

 +47      ;;  - Most recent TB HF

 +48      ;;  - Most recent SDM HF

 +49      ;;  - Most recent Alcohol HF

 +50      ;;

 +51      ;;For additional information contact your RPMS site manager, Area Office RPMS

 +52      ;;support staff or any of the following Cimarron staff members:

 +53      ;;

 +54      ;;Dorothy Russell *  Gary Lawless    *  Bill Mason       *  Lori Butcher

 +55      ;;(520)-743-3275     (715)-358-3763     (520)-615-0689      (520)-577-2146

 +56      ;;  

 +57      ;;+++++++++++++++++++++ end of announcement +++++++++++++++++++++++

 +58      ;;###

 +59      ;

GETRECIP  ;

 +1       ;* * * Define key below to identify recipients * * *

 +2       ;

 +3        SET CTR=0

           SET APCPKEY="APCPZMENU"

 +4        FOR 

               SET CTR=$ORDER(^XUSEC(APCPKEY,CTR))

               IF 'CTR

                   QUIT 

               SET Y=CTR

               SET XMY(Y)=""

 +5        QUIT 

LAB       ;

 +1        SET APCPX="APCP PAP SMEAR TESTS"

           DO PAPLAB1

 +2        SET APCPX="APCP PSA TESTS TAX"

           DO PSALAB1

 +3        QUIT 

PAPLAB1   ;

 +1        WRITE !,"Creating ",APCPX," Taxonomy..."

 +2        SET APCPDA=$ORDER(^ATXLAB("B",APCPX,0))

 +3       ;taxonomy already exisits

           IF APCPDA

               QUIT 

 +4        SET X=APCPX

           SET DIC="^ATXLAB("

           SET DIC(0)="L"

           SET DIADD=1

           SET DLAYGO=9002228

           DO ^DIC

           KILL DIC,DA,DIADD,DLAYGO,I

 +5        IF Y=-1

               WRITE !!,"ERROR IN CREATING ",APCPX," TAX"

               QUIT 

 +6        SET APCPTX=+Y

           SET $PIECE(^ATXLAB(APCPTX,0),U,2)=APCPX

           SET $PIECE(^(0),U,5)=DUZ

           SET $PIECE(^(0),U,6)=DT

           SET $PIECE(^(0),U,8)="B"

           SET $PIECE(^(0),U,9)=60

           SET ^ATXLAB(APCPTX,21,0)="^9002228.02101PA^0^0"

 +7        SET APCPX=$ORDER(^LAB(60,"B","PAP SMEAR",0))

 +8        IF APCPX

               SET ^ATXLAB(APCPTX,21,1,0)=APCPX

               SET ^ATXLAB(APCPTX,21,"B",APCPX,1)=""

               SET $PIECE(^ATXLAB(APCPTX,21,0),U,3)=APCPX

               SET $PIECE(^ATXLAB(APCPTX,21,0),U,4)=1

 +9        SET DA=APCPTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +10       QUIT 

 +11      ;

PSALAB1   ;

 +1        WRITE !,"Creating ",APCPX," Taxonomy..."

 +2        SET APCPDA=$ORDER(^ATXLAB("B",APCPX,0))

 +3       ;taxonomy already exisits

           IF APCPDA

               QUIT 

 +4        SET X=APCPX

           SET DIC="^ATXLAB("

           SET DIC(0)="L"

           SET DIADD=1

           SET DLAYGO=9002228

           DO ^DIC

           KILL DIC,DA,DIADD,DLAYGO,I

 +5        IF Y=-1

               WRITE !!,"ERROR IN CREATING ",APCPX," TAX"

               QUIT 

 +6        SET APCPTX=+Y

           SET $PIECE(^ATXLAB(APCPTX,0),U,2)=APCPX

           SET $PIECE(^(0),U,5)=DUZ

           SET $PIECE(^(0),U,6)=DT

           SET $PIECE(^(0),U,8)="B"

           SET $PIECE(^(0),U,9)=60

           SET ^ATXLAB(APCPTX,21,0)="^9002228.02101PA^0^0"

 +7        SET APCPX=$ORDER(^LAB(60,"B","PSA",0))

 +8        IF APCPX

               SET ^ATXLAB(APCPTX,21,1,0)=APCPX

               SET ^ATXLAB(APCPTX,21,"B",APCPX,1)=""

               SET $PIECE(^ATXLAB(APCPTX,21,0),U,3)=APCPX

               SET $PIECE(^ATXLAB(APCPTX,21,0),U,4)=1

 +9        SET DA=APCPTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +10       QUIT 

 +11      ;