APCLP19.m

APCLP19 ; 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*18") 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

 NEW X

 S X=$$ADD^XPDMENU("APCL M MAN APC REPORTS/PCC","APCL P APC PCC 1A - MULT FACS","A1M")

 I 'X W "Attempt to add 1A MULT FACILITIES report option failed.." H 3

 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")

 S X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL M DV REPORTS","DVR")

 I 'X W "Attempt to add DV REPORTS menu option failed.." H 3

 S X=$$ADD^XPDMENU("APCL M DX/PROC COUNT REPORTS","APCL OPERATING PROVIDER REPORT","TOP")

 I 'X W "Attempt to add DV REPORTS menu option failed.." H 3

 S X=$$ADD^XPDMENU("APCL M MAN QUALITY ASSURANCE","APCL P RETURNS TO CLINIC","RT1")

 I 'X W "Attempt to add RETURNS TO CLINIC report option failed.." H 3

 S X=$$ADD^XPDMENU("APCL M DX/PROC COUNT REPORTS","APCL P CPT BY PROVIDER","CPTP")

 I 'X W "Attempt to add CPT BY PROVIDER REPORT menu option failed.." H 3

 S X=$$ADD^XPDMENU("APCL M MAN REPORTS BMI","APCL P BMI MOVE","MBC")

 I 'X W "Attempt to add BMI MOVE menu option failed.." H 3

 ;S X=$$ADD^XPDMENU("APCL M MAIN DM MENU","APCL DM2005 AUDIT MENU","DM05",2)

 ;I 'X W "Attempt to add 2005 DM AUDIT menu option failed.." H 3

 S X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL MENU SUICIDE REPORTS","SUIC")

 I 'X W "Attempt to add SUICIDE REPORTS menu option failed.." H 3

 S X=$$ADD^XPDMENU("APCL M MAN ALL REPORTS","APCL P PCCV TALLY PROV/CLN","TPC")

 I 'X W "Attempt to add TALLY BY PROV/CLINIC menu option failed.." H 3

 ;S X=$$ADD^XPDMENU("APCL M MAIN DM MENU","APCL DM SELF MONITORING","SMBG")

 I 'X W "Attempt to add Self Monitoring Report failed.." H 3

 S X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL P PLST DECEASED PTS","DPL")

 I 'X W "Attempt to add DECEASED PTS LISTING menu option failed.." H 3

 S X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL P PLST THI/NHH","THI")

 I 'X W "Attempt to add TOTAL HOUSEHOLD INCOME LISTING menu option failed.." H 3

 S X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL M INFANT FEEDING","IF")

 I 'X W "Attempt to add INFANT FEEDING REPORTS menu option failed.." H 3

 S APCLX="APCL P BILL THIRD PARTY",APCLY="TPR"

 S X=$$ADD^XPDMENU("APCL M MAN BILLING REPORTS",APCLX,APCLY)

 S X=$$ADD^XPDMENU("APCLMENU","APCLLT CUSTOM LETTER MGT","CLM")

 ;S X=$$ADD^XPDMENU("APCL M MAIN DM MENU","APCL DM2006 AUDIT MENU","DM06",1)

 ;I 'X W "Attempt to add 2006 DM AUDIT menu option failed.." H 3

 S X=$$DELETE^XPDMENU("APCLMENU","APCL P DATA FETCHER")

 S X=$$DELETE^XPDMENU("APCLMENU","APCL M REPORT TEMPLATE")

 S X=$$DELETE^XPDMENU("APCLMENU","APCL P QA DELETE REP DEF")

 S X=$$ADD^XPDMENU("APCLMENU","APCL M OTHER REPORTS","OTH")

 S X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL P PRESCRIPTION COST","PCR")

 S X=$$ADD^XPDMENU("APCL M MAIN DM MENU","APCL DM2007 AUDIT MENU","DM07",1)

 S X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL M SCREENING REPORTS","SCR")

 S X=$$DELETE^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL M DV REPORTS")

 ;

 D DUPE  ;delete out duplicate lab taxonomies

 D LAB

 D ^APCL1TX

 D ^APCL2TX

 D TAXREAD

 ;rename DM AUDIT TROGLITIZONE TO GLITAZONE

 S ATXFLG=1

 S DA=$O(^ATXAX("B","DM AUDIT TROGLITAZONE DRUGS",0))

 I DA S DIE="^ATXAX(",DR=".01///DM AUDIT GLITAZONE DRUGS" D ^DIE,^XBFMK

 ;ADD TAXONOMY TYPE FOR LOINC

 D ^XBFMK

 S APCLDA=$O(^ATXTYPE("B","LOINC CODES",0))

 I 'APCLDA D

 .S DIC="^ATXTYPE(",DIC(0)="L",DIADD=1,DLAYGO=9002229,X="LOINC CODES",DIC("DR")=".02////95.3;.04////1" K DD,DO,D0 D FILE^DICN

 .D ^XBFMK K DIADD,DLAYGO

 .Q

 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","V3P19",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

DUPE ;

 S (APCLX,APCLC)=0 F  S APCLX=$O(^ATXLAB("B","DM AUDIT FASTING GLUCOSE TESTS",APCLX)) Q:APCLX'=+APCLX  S APCLC=APCLC+1 D

 .Q:APCLC=1

 .S DA=APCLX,DIK="^ATXLAB(" D ^DIK

 .Q

 S (APCLX,APCLC)=0 F  S APCLX=$O(^ATXLAB("B","DM AUDIT 75GM 2HR GLUCOSE",APCLX)) Q:APCLX'=+APCLX  S APCLC=APCLC+1 D

 .Q:APCLC=1

 .S DA=APCLX,DIK="^ATXLAB(" D ^DIK

 .Q

 S (APCLX,APCLC)=0 F  S APCLX=$O(^ATXLAB("B","DM AUDIT A/C RATIO TAX",APCLX)) Q:APCLX'=+APCLX  S APCLC=APCLC+1 D

 .Q:APCLC=1

 .S DA=APCLX,DIK="^ATXLAB(" D ^DIK

 .Q

 Q

LAB ;

 S APCLX="DM AUDIT FASTING GLUCOSE TESTS" D LAB1

 S APCLX="DM AUDIT 75GM 2HR GLUCOSE" D LAB1

 S APCLX="DM AUDIT A/C RATIO TAX" D LAB1

 Q

LAB1 ;

 S APCLDA=$O(^ATXLAB("B",APCLX,0))

 I APCLDA S $P(^ATXLAB(APCLDA,0),U,4)="n",$P(^ATXLAB(APCLDA,0),U,22)=0 Q  ;taxonomy already exisits, set nodelete and read only

 W !,"Creating ",APCLX," Taxonomy..."

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

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

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

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

 Q

SETTAXL ;

 Q:'$D(^DD(9002228,4101,0))  ;taxonomy patch not yet installed

 S APCLTEXT="LABTAX" F APCLX=1:1 S APCLDATA=$P($T(@APCLTEXT+APCLX),";;",2) Q:APCLDATA=""  D

 .S APCLDA=$O(^ATXLAB("B",$P(APCLDATA,"|"),0))

 .Q:APCLDA=""

 .S $P(^ATXLAB(APCLDA,0),U,4)="n" W !,$P(APCLDATA,"|")  ;SET NO DELETE

 .S $P(^ATXLAB(APCLDA,0),U,22)=$P(APCLDATA,"|",2) ;set read only

 .;set packages in multiple

 .K DIC,DA,DR

 .S APCLP=$P(APCLDATA,"|",3)

 .F APCLN=1:1 S APCLPP=$P(APCLP,"*",APCLN) Q:APCLPP=""  D

 ..S APCLPI=$O(^DIC(9.4,"C",APCLPP,0))

 ..Q:APCLPI=""  ;NO PACKAGE

 ..S X="`"_APCLPI,DIC="^ATXLAB("_APCLDA_",41,",DIC(0)="L",DIC("P")=$P(^DD(9002228,4101,0),U,2),DA(1)=APCLDA

 ..D ^DIC

 ..I Y=-1 W !,"updating package multiple for ",APCLPP," entry ",$P(^ATXLAB(APCLDA,0),U)," failed"

 ..K DIC,DA,Y,X

 .Q

 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

LABTAX ;

 ;;DM AUDIT FASTING GLUCOSE TESTS|0|APCL

 ;;DM AUDIT 75GM 2HR GLUCOSE|0|APCL

 ;;

TAXREAD ;

 S ATXPNSP=""

 S APCLTEXT="TAX" F APCLX=1:1 S APCLDATA=$P($T(@APCLTEXT+APCLX),";;",2) Q:APCLDATA=""  D

 .S APCLDA=$O(^ATXAX("B",$P(APCLDATA,"|"),0))

 .Q:APCLDA=""

 .S $P(^ATXAX(APCLDA,0),U,4)="n" W !,$P(APCLDATA,"|")  ;SET NO DELETE

 .S $P(^ATXAX(APCLDA,0),U,22)=$P(APCLDATA,"|",2) ;set read only

 .;set packages in multiple

 .K DIC,DA,DR

 .S APCLP=$P(APCLDATA,"|",3)

 .F APCLN=1:1 S APCLPP=$P(APCLP,"*",APCLN) Q:APCLPP=""  D

 ..S APCLPI=$O(^DIC(9.4,"C",APCLPP,0))

 ..Q:APCLPI=""  ;NO PACKAGE

 ..S X="`"_APCLPI,DIC="^ATXAX("_APCLDA_",41,",DIC(0)="L",DIC("P")=$P(^DD(9002226,4101,0),U,2),DA(1)=APCLDA

 ..D ^DIC

 ..I Y=-1 W !,"updating package multiple for ",APCLPP," entry ",$P(^ATXAX(APCLDA,0),U)," failed"

 ..K DIC,DA,Y,X

 .Q

 Q

SET ;

 S X=0 F  S X=$O(^ATXAX(X)) Q:X'=+X  D

 .S Y=$P(^ATXAX(X,0),U)

 .S L=$L(APCLPNSP)

 .I $E(Y,1,L)=APCLPNSP S $P(^ATXAX(X,0),U,4)="n" W !,Y

 .Q

 Q

TAX ;

 ;;APCL CAR CNM|0|APCL

 ;;APCL CAR DENTISTS|0|APCL

 ;;APCL CAR FNP|0|APCL

 ;;APCL CAR LCSW|0|APCL

 ;;APCL CAR LVN|0|APCL

 ;;APCL CAR OTHER PROVIDERS|0|APCL

 ;;APCL CAR OTHER2|0|APCL

 ;;APCL CAR PA|0|APCL

 ;;APCL CAR PHYSICIANS|0|APCL

 ;;APCL CAR PSYCHIATRIST|0|APCL

 ;;APCL CAR PSYCHOLOGIST|0|APCL

 ;;APCL CAR PT ED|0|APCL

 ;;APCL CAR RDA|0|APCL

 ;;APCL CAR RN|0|APCL

 ;;APCL DIABETES REG COMPLICATION|0|APCL*BDM

 ;;APCL DIABETES REG NEW CASE|0|APCL*BDM

 ;;APCL HRSA TABLE 6 LINE 16|1

 ;;APCL HRSA TABLE 6 LINE 17|1

 ;;APCL HRSA TABLE 6 LINE 20|1

 ;;APCL INJ AIR TRANSPORT|1|APCL

 ;;APCL INJ ANIMAL RELATED|1|APCL

 ;;APCL INJ ASSAULTS|1|APCL

 ;;APCL INJ BATTERED CHILD|1|APCL

 ;;APCL INJ CUT|1|APCL

 ;;APCL INJ DROWNING|1|APCL

 ;;APCL INJ ENVIRONMENTAL FACTORS|1|APCL

 ;;APCL INJ FALLS|1|APCL

 ;;APCL INJ FIRE|1|APCL

 ;;APCL INJ FIREARMS|1|APCL

 ;;APCL INJ MOTOR|1|APCL

 ;;APCL INJ OTHER CAUSES|1|APCL

 ;;APCL INJ POISONING|1|APCL

 ;;APCL INJ SPORTS|1|APCL

 ;;APCL INJ STINGS VENOMS|1|APCL

 ;;APCL INJ SUICIDE|1|APCL

 ;;APCL INJ UNDETERMINED|1|APCL

 ;;APCL INJ WATER TRANSPORT|1|APCL

 ;;DM AUDIT 75GM 2HR LOINC|1|APCL*APCH

 ;;DM AUDIT A/C RATIO LOINC|1|APCL

 ;;DM AUDIT ACARBOSE DRUGS|0|APCL*BDM

 ;;DM AUDIT ACE INHIBITORS|0|APCL*BDM

 ;;DM AUDIT ANTI-PLATELET DRUGS|0|APCL*BDM

 ;;DM AUDIT ASPIRIN DRUGS|0|APCL*BDM

 ;;DM AUDIT CESSATION HLTH FACTOR|0|APCL*BDM

 ;;DM AUDIT DENTAL EXAM ADA CODES|0|APCL*BDM

 ;;DM AUDIT DEPRESSIVE DISORDERS|1|APCL*BDM

 ;;DM AUDIT DIABETES EDUC TOPICS|0|APCL*BDM

 ;;DM AUDIT DIET EDUC TOPICS|0|APCL*BDM

 ;;DM AUDIT EKG CPTS|1|APCL*BDM

 ;;DM AUDIT ESTIMATED GFR LOINC|1|APCL*APCH

 ;;DM AUDIT EXCERCISE EDUC TOPICS|0|APCL

 ;;DM AUDIT EXERCISE EDUC TOPICS|0|APCL

 ;;DM AUDIT EYE EXAM DXS|1|APCL*BDM

 ;;DM AUDIT FASTING GLUC LOINC|1|APCL*APCH

 ;;DM AUDIT FLU CPTS|1|APCL*BDM

 ;;DM AUDIT INSULIN DRUGS|0|APCL*BDM

 ;;DM AUDIT LIPID LOWERING DRUGS|0|APCL*BDM

 ;;DM AUDIT MAMMOGRAM CPTS|1|APCL*BDM

 ;;DM AUDIT METFORMIN DRUGS|0|APCL*BDM

 ;;DM AUDIT ORAL HYPOGLYCEMICS|0|APCL*BDM

 ;;DM AUDIT OTHER EDUC TOPICS|0|APCL*BDM

 ;;DM AUDIT PAP CPTS|1|APCL*BDM

 ;;DM AUDIT PERIDONTAL ADA CODES|0|APCL*BDM

 ;;DM AUDIT PNEUMO CPTS|1|APCL*BDM

 ;;DM AUDIT PRE-DIABETES DXS|1|APCL*BDM*APCH

 ;;DM AUDIT PROBLEM DIABETES DX|1|APCL*BDM

 ;;DM AUDIT PROBLEM HTN DIAGNOSES|1|APCL*BDM

 ;;DM AUDIT PROBLEM SMOKING DXS|1|APCL*BDM

 ;;DM AUDIT PROBLEM TB DXS|1|APCL*BDM

 ;;DM AUDIT SDM PROVIDERS|0|APCL*BDM

 ;;DM AUDIT SELF MONITOR DRUGS|0|APCL*BDM

 ;;DM AUDIT SMOKING CESS EDUC|0|APCL*BDM

 ;;DM AUDIT SMOKING RELATED DXS|1|APCL*BDM

 ;;DM AUDIT STATIN DRUGS|0|APCL*BDM

 ;;DM AUDIT SULFONYLUREA DRUGS|0|APCL*BDM

 ;;DM AUDIT TB HEALTH FACTORS|0|APCL*BDM

 ;;DM AUDIT TD CPTS|1|APCL*BDM

 ;;DM AUDIT TOBACCO HLTH FACTORS|0|APCL*BDM

 ;;DM AUDIT GLITAZONE DRUGS|0|APCL*BDM

 ;;DM AUDIT TYPE I DXS|1|APCL*BDM

 ;;DM AUDIT TYPE II DXS|1|APCL*BDM

 ;;DM AUDIT MICROALBUMIN LOINC CODES|1|APCL

 ;;DM AUDIT URINALYSIS LOINC|1|APCL

 ;;DM AUDIT URINE PROTEIN LOINC|1|APCL

 ;;

APCLP19   ; 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*18")

               DO SORRY(2)

 +8        QUIT 

 +9       ;

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        NEW X

 +2        SET X=$$ADD^XPDMENU("APCL M MAN APC REPORTS/PCC","APCL P APC PCC 1A - MULT FACS","A1M")

 +3        IF 'X

               WRITE "Attempt to add 1A MULT FACILITIES report option failed.."

               HANG 3

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

 +5        IF 'X

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

               HANG 3

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

 +7        SET X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL M DV REPORTS","DVR")

 +8        IF 'X

               WRITE "Attempt to add DV REPORTS menu option failed.."

               HANG 3

 +9        SET X=$$ADD^XPDMENU("APCL M DX/PROC COUNT REPORTS","APCL OPERATING PROVIDER REPORT","TOP")

 +10       IF 'X

               WRITE "Attempt to add DV REPORTS menu option failed.."

               HANG 3

 +11       SET X=$$ADD^XPDMENU("APCL M MAN QUALITY ASSURANCE","APCL P RETURNS TO CLINIC","RT1")

 +12       IF 'X

               WRITE "Attempt to add RETURNS TO CLINIC report option failed.."

               HANG 3

 +13       SET X=$$ADD^XPDMENU("APCL M DX/PROC COUNT REPORTS","APCL P CPT BY PROVIDER","CPTP")

 +14       IF 'X

               WRITE "Attempt to add CPT BY PROVIDER REPORT menu option failed.."

               HANG 3

 +15       SET X=$$ADD^XPDMENU("APCL M MAN REPORTS BMI","APCL P BMI MOVE","MBC")

 +16       IF 'X

               WRITE "Attempt to add BMI MOVE menu option failed.."

               HANG 3

 +17      ;S X=$$ADD^XPDMENU("APCL M MAIN DM MENU","APCL DM2005 AUDIT MENU","DM05",2)

 +18      ;I 'X W "Attempt to add 2005 DM AUDIT menu option failed.." H 3

 +19       SET X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL MENU SUICIDE REPORTS","SUIC")

 +20       IF 'X

               WRITE "Attempt to add SUICIDE REPORTS menu option failed.."

               HANG 3

 +21       SET X=$$ADD^XPDMENU("APCL M MAN ALL REPORTS","APCL P PCCV TALLY PROV/CLN","TPC")

 +22       IF 'X

               WRITE "Attempt to add TALLY BY PROV/CLINIC menu option failed.."

               HANG 3

 +23      ;S X=$$ADD^XPDMENU("APCL M MAIN DM MENU","APCL DM SELF MONITORING","SMBG")

 +24       IF 'X

               WRITE "Attempt to add Self Monitoring Report failed.."

               HANG 3

 +25       SET X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL P PLST DECEASED PTS","DPL")

 +26       IF 'X

               WRITE "Attempt to add DECEASED PTS LISTING menu option failed.."

               HANG 3

 +27       SET X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL P PLST THI/NHH","THI")

 +28       IF 'X

               WRITE "Attempt to add TOTAL HOUSEHOLD INCOME LISTING menu option failed.."

               HANG 3

 +29       SET X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL M INFANT FEEDING","IF")

 +30       IF 'X

               WRITE "Attempt to add INFANT FEEDING REPORTS menu option failed.."

               HANG 3

 +31       SET APCLX="APCL P BILL THIRD PARTY"

           SET APCLY="TPR"

 +32       SET X=$$ADD^XPDMENU("APCL M MAN BILLING REPORTS",APCLX,APCLY)

 +33       SET X=$$ADD^XPDMENU("APCLMENU","APCLLT CUSTOM LETTER MGT","CLM")

 +34      ;S X=$$ADD^XPDMENU("APCL M MAIN DM MENU","APCL DM2006 AUDIT MENU","DM06",1)

 +35      ;I 'X W "Attempt to add 2006 DM AUDIT menu option failed.." H 3

 +36       SET X=$$DELETE^XPDMENU("APCLMENU","APCL P DATA FETCHER")

 +37       SET X=$$DELETE^XPDMENU("APCLMENU","APCL M REPORT TEMPLATE")

 +38       SET X=$$DELETE^XPDMENU("APCLMENU","APCL P QA DELETE REP DEF")

 +39       SET X=$$ADD^XPDMENU("APCLMENU","APCL M OTHER REPORTS","OTH")

 +40       SET X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL P PRESCRIPTION COST","PCR")

 +41       SET X=$$ADD^XPDMENU("APCL M MAIN DM MENU","APCL DM2007 AUDIT MENU","DM07",1)

 +42       SET X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL M SCREENING REPORTS","SCR")

 +43       SET X=$$DELETE^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL M DV REPORTS")

 +44      ;

 +45      ;delete out duplicate lab taxonomies

           DO DUPE

 +46       DO LAB

 +47       DO ^APCL1TX

 +48       DO ^APCL2TX

 +49       DO TAXREAD

 +50      ;rename DM AUDIT TROGLITIZONE TO GLITAZONE

 +51       SET ATXFLG=1

 +52       SET DA=$ORDER(^ATXAX("B","DM AUDIT TROGLITAZONE DRUGS",0))

 +53       IF DA

               SET DIE="^ATXAX("

               SET DR=".01///DM AUDIT GLITAZONE DRUGS"

               DO ^DIE

               DO ^XBFMK

 +54      ;ADD TAXONOMY TYPE FOR LOINC

 +55       DO ^XBFMK

 +56       SET APCLDA=$ORDER(^ATXTYPE("B","LOINC CODES",0))

 +57       IF 'APCLDA

               Begin DoDot:1

 +58               SET DIC="^ATXTYPE("

                   SET DIC(0)="L"

                   SET DIADD=1

                   SET DLAYGO=9002229

                   SET X="LOINC CODES"

                   SET DIC("DR")=".02////95.3;.04////1"

                   KILL DD,DO,D0

                   DO FILE^DICN

 +59               DO ^XBFMK

                   KILL DIADD,DLAYGO

 +60               QUIT 

               End DoDot:1

 +61       IF '$GET(DUZ)

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

               QUIT 

 +62       DO HOME^%ZIS

           DO DT^DICRW

 +63      ;

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

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

 +66       DO WRITEMSG

           DO GETRECIP

 +67      ;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","V3P19",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 

DUPE      ;

 +1        SET (APCLX,APCLC)=0

           FOR 

               SET APCLX=$ORDER(^ATXLAB("B","DM AUDIT FASTING GLUCOSE TESTS",APCLX))

               IF APCLX'=+APCLX

                   QUIT 

               SET APCLC=APCLC+1

               Begin DoDot:1

 +2                IF APCLC=1

                       QUIT 

 +3                SET DA=APCLX

                   SET DIK="^ATXLAB("

                   DO ^DIK

 +4                QUIT 

               End DoDot:1

 +5        SET (APCLX,APCLC)=0

           FOR 

               SET APCLX=$ORDER(^ATXLAB("B","DM AUDIT 75GM 2HR GLUCOSE",APCLX))

               IF APCLX'=+APCLX

                   QUIT 

               SET APCLC=APCLC+1

               Begin DoDot:1

 +6                IF APCLC=1

                       QUIT 

 +7                SET DA=APCLX

                   SET DIK="^ATXLAB("

                   DO ^DIK

 +8                QUIT 

               End DoDot:1

 +9        SET (APCLX,APCLC)=0

           FOR 

               SET APCLX=$ORDER(^ATXLAB("B","DM AUDIT A/C RATIO TAX",APCLX))

               IF APCLX'=+APCLX

                   QUIT 

               SET APCLC=APCLC+1

               Begin DoDot:1

 +10               IF APCLC=1

                       QUIT 

 +11               SET DA=APCLX

                   SET DIK="^ATXLAB("

                   DO ^DIK

 +12               QUIT 

               End DoDot:1

 +13       QUIT 

LAB       ;

 +1        SET APCLX="DM AUDIT FASTING GLUCOSE TESTS"

           DO LAB1

 +2        SET APCLX="DM AUDIT 75GM 2HR GLUCOSE"

           DO LAB1

 +3        SET APCLX="DM AUDIT A/C RATIO TAX"

           DO LAB1

 +4        QUIT 

LAB1      ;

 +1        SET APCLDA=$ORDER(^ATXLAB("B",APCLX,0))

 +2       ;taxonomy already exisits, set nodelete and read only

           IF APCLDA

               SET $PIECE(^ATXLAB(APCLDA,0),U,4)="n"

               SET $PIECE(^ATXLAB(APCLDA,0),U,22)=0

               QUIT 

 +3        WRITE !,"Creating ",APCLX," Taxonomy..."

 +4        SET X=APCLX

           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 ",APCLX," TAX"

               QUIT 

 +6        SET APCLTX=+Y

           SET $PIECE(^ATXLAB(APCLTX,0),U,2)=APCLX

           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(APCLTX,21,0)="^9002228.02101PA^0^0"

 +7        SET DA=APCLTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +8        QUIT 

SETTAXL   ;

 +1       ;taxonomy patch not yet installed

           IF '$DATA(^DD(9002228,4101,0))

               QUIT 

 +2        SET APCLTEXT="LABTAX"

           FOR APCLX=1:1

               SET APCLDATA=$PIECE($TEXT(@APCLTEXT+APCLX),";;",2)

               IF APCLDATA=""

                   QUIT 

               Begin DoDot:1

 +3                SET APCLDA=$ORDER(^ATXLAB("B",$PIECE(APCLDATA,"|"),0))

 +4                IF APCLDA=""

                       QUIT 

 +5       ;SET NO DELETE

                   SET $PIECE(^ATXLAB(APCLDA,0),U,4)="n"

                   WRITE !,$PIECE(APCLDATA,"|")

 +6       ;set read only

                   SET $PIECE(^ATXLAB(APCLDA,0),U,22)=$PIECE(APCLDATA,"|",2)

 +7       ;set packages in multiple

 +8                KILL DIC,DA,DR

 +9                SET APCLP=$PIECE(APCLDATA,"|",3)

 +10               FOR APCLN=1:1

                       SET APCLPP=$PIECE(APCLP,"*",APCLN)

                       IF APCLPP=""

                           QUIT 

                       Begin DoDot:2

 +11                       SET APCLPI=$ORDER(^DIC(9.4,"C",APCLPP,0))

 +12      ;NO PACKAGE

                           IF APCLPI=""

                               QUIT 

 +13                       SET X="`"_APCLPI

                           SET DIC="^ATXLAB("_APCLDA_",41,"

                           SET DIC(0)="L"

                           SET DIC("P")=$PIECE(^DD(9002228,4101,0),U,2)

                           SET DA(1)=APCLDA

 +14                       DO ^DIC

 +15                       IF Y=-1

                               WRITE !,"updating package multiple for ",APCLPP," entry ",$PIECE(^ATXLAB(APCLDA,0),U)," failed"

 +16                       KILL DIC,DA,Y,X

                       End DoDot:2

 +17               QUIT 

               End DoDot:1

 +18       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 

LABTAX    ;

 +1       ;;DM AUDIT FASTING GLUCOSE TESTS|0|APCL

 +2       ;;DM AUDIT 75GM 2HR GLUCOSE|0|APCL

 +3       ;;

TAXREAD   ;

 +1        SET ATXPNSP=""

 +2        SET APCLTEXT="TAX"

           FOR APCLX=1:1

               SET APCLDATA=$PIECE($TEXT(@APCLTEXT+APCLX),";;",2)

               IF APCLDATA=""

                   QUIT 

               Begin DoDot:1

 +3                SET APCLDA=$ORDER(^ATXAX("B",$PIECE(APCLDATA,"|"),0))

 +4                IF APCLDA=""

                       QUIT 

 +5       ;SET NO DELETE

                   SET $PIECE(^ATXAX(APCLDA,0),U,4)="n"

                   WRITE !,$PIECE(APCLDATA,"|")

 +6       ;set read only

                   SET $PIECE(^ATXAX(APCLDA,0),U,22)=$PIECE(APCLDATA,"|",2)

 +7       ;set packages in multiple

 +8                KILL DIC,DA,DR

 +9                SET APCLP=$PIECE(APCLDATA,"|",3)

 +10               FOR APCLN=1:1

                       SET APCLPP=$PIECE(APCLP,"*",APCLN)

                       IF APCLPP=""

                           QUIT 

                       Begin DoDot:2

 +11                       SET APCLPI=$ORDER(^DIC(9.4,"C",APCLPP,0))

 +12      ;NO PACKAGE

                           IF APCLPI=""

                               QUIT 

 +13                       SET X="`"_APCLPI

                           SET DIC="^ATXAX("_APCLDA_",41,"

                           SET DIC(0)="L"

                           SET DIC("P")=$PIECE(^DD(9002226,4101,0),U,2)

                           SET DA(1)=APCLDA

 +14                       DO ^DIC

 +15                       IF Y=-1

                               WRITE !,"updating package multiple for ",APCLPP," entry ",$PIECE(^ATXAX(APCLDA,0),U)," failed"

 +16                       KILL DIC,DA,Y,X

                       End DoDot:2

 +17               QUIT 

               End DoDot:1

 +18       QUIT 

SET       ;

 +1        SET X=0

           FOR 

               SET X=$ORDER(^ATXAX(X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +2                SET Y=$PIECE(^ATXAX(X,0),U)

 +3                SET L=$LENGTH(APCLPNSP)

 +4                IF $EXTRACT(Y,1,L)=APCLPNSP

                       SET $PIECE(^ATXAX(X,0),U,4)="n"

                       WRITE !,Y

 +5                QUIT 

               End DoDot:1

 +6        QUIT 

TAX       ;

 +1       ;;APCL CAR CNM|0|APCL

 +2       ;;APCL CAR DENTISTS|0|APCL

 +3       ;;APCL CAR FNP|0|APCL

 +4       ;;APCL CAR LCSW|0|APCL

 +5       ;;APCL CAR LVN|0|APCL

 +6       ;;APCL CAR OTHER PROVIDERS|0|APCL

 +7       ;;APCL CAR OTHER2|0|APCL

 +8       ;;APCL CAR PA|0|APCL

 +9       ;;APCL CAR PHYSICIANS|0|APCL

 +10      ;;APCL CAR PSYCHIATRIST|0|APCL

 +11      ;;APCL CAR PSYCHOLOGIST|0|APCL

 +12      ;;APCL CAR PT ED|0|APCL

 +13      ;;APCL CAR RDA|0|APCL

 +14      ;;APCL CAR RN|0|APCL

 +15      ;;APCL DIABETES REG COMPLICATION|0|APCL*BDM

 +16      ;;APCL DIABETES REG NEW CASE|0|APCL*BDM

 +17      ;;APCL HRSA TABLE 6 LINE 16|1

 +18      ;;APCL HRSA TABLE 6 LINE 17|1

 +19      ;;APCL HRSA TABLE 6 LINE 20|1

 +20      ;;APCL INJ AIR TRANSPORT|1|APCL

 +21      ;;APCL INJ ANIMAL RELATED|1|APCL

 +22      ;;APCL INJ ASSAULTS|1|APCL

 +23      ;;APCL INJ BATTERED CHILD|1|APCL

 +24      ;;APCL INJ CUT|1|APCL

 +25      ;;APCL INJ DROWNING|1|APCL

 +26      ;;APCL INJ ENVIRONMENTAL FACTORS|1|APCL

 +27      ;;APCL INJ FALLS|1|APCL

 +28      ;;APCL INJ FIRE|1|APCL

 +29      ;;APCL INJ FIREARMS|1|APCL

 +30      ;;APCL INJ MOTOR|1|APCL

 +31      ;;APCL INJ OTHER CAUSES|1|APCL

 +32      ;;APCL INJ POISONING|1|APCL

 +33      ;;APCL INJ SPORTS|1|APCL

 +34      ;;APCL INJ STINGS VENOMS|1|APCL

 +35      ;;APCL INJ SUICIDE|1|APCL

 +36      ;;APCL INJ UNDETERMINED|1|APCL

 +37      ;;APCL INJ WATER TRANSPORT|1|APCL

 +38      ;;DM AUDIT 75GM 2HR LOINC|1|APCL*APCH

 +39      ;;DM AUDIT A/C RATIO LOINC|1|APCL

 +40      ;;DM AUDIT ACARBOSE DRUGS|0|APCL*BDM

 +41      ;;DM AUDIT ACE INHIBITORS|0|APCL*BDM

 +42      ;;DM AUDIT ANTI-PLATELET DRUGS|0|APCL*BDM

 +43      ;;DM AUDIT ASPIRIN DRUGS|0|APCL*BDM

 +44      ;;DM AUDIT CESSATION HLTH FACTOR|0|APCL*BDM

 +45      ;;DM AUDIT DENTAL EXAM ADA CODES|0|APCL*BDM

 +46      ;;DM AUDIT DEPRESSIVE DISORDERS|1|APCL*BDM

 +47      ;;DM AUDIT DIABETES EDUC TOPICS|0|APCL*BDM

 +48      ;;DM AUDIT DIET EDUC TOPICS|0|APCL*BDM

 +49      ;;DM AUDIT EKG CPTS|1|APCL*BDM

 +50      ;;DM AUDIT ESTIMATED GFR LOINC|1|APCL*APCH

 +51      ;;DM AUDIT EXCERCISE EDUC TOPICS|0|APCL

 +52      ;;DM AUDIT EXERCISE EDUC TOPICS|0|APCL

 +53      ;;DM AUDIT EYE EXAM DXS|1|APCL*BDM

 +54      ;;DM AUDIT FASTING GLUC LOINC|1|APCL*APCH

 +55      ;;DM AUDIT FLU CPTS|1|APCL*BDM

 +56      ;;DM AUDIT INSULIN DRUGS|0|APCL*BDM

 +57      ;;DM AUDIT LIPID LOWERING DRUGS|0|APCL*BDM

 +58      ;;DM AUDIT MAMMOGRAM CPTS|1|APCL*BDM

 +59      ;;DM AUDIT METFORMIN DRUGS|0|APCL*BDM

 +60      ;;DM AUDIT ORAL HYPOGLYCEMICS|0|APCL*BDM

 +61      ;;DM AUDIT OTHER EDUC TOPICS|0|APCL*BDM

 +62      ;;DM AUDIT PAP CPTS|1|APCL*BDM

 +63      ;;DM AUDIT PERIDONTAL ADA CODES|0|APCL*BDM

 +64      ;;DM AUDIT PNEUMO CPTS|1|APCL*BDM

 +65      ;;DM AUDIT PRE-DIABETES DXS|1|APCL*BDM*APCH

 +66      ;;DM AUDIT PROBLEM DIABETES DX|1|APCL*BDM

 +67      ;;DM AUDIT PROBLEM HTN DIAGNOSES|1|APCL*BDM

 +68      ;;DM AUDIT PROBLEM SMOKING DXS|1|APCL*BDM

 +69      ;;DM AUDIT PROBLEM TB DXS|1|APCL*BDM

 +70      ;;DM AUDIT SDM PROVIDERS|0|APCL*BDM

 +71      ;;DM AUDIT SELF MONITOR DRUGS|0|APCL*BDM

 +72      ;;DM AUDIT SMOKING CESS EDUC|0|APCL*BDM

 +73      ;;DM AUDIT SMOKING RELATED DXS|1|APCL*BDM

 +74      ;;DM AUDIT STATIN DRUGS|0|APCL*BDM

 +75      ;;DM AUDIT SULFONYLUREA DRUGS|0|APCL*BDM

 +76      ;;DM AUDIT TB HEALTH FACTORS|0|APCL*BDM

 +77      ;;DM AUDIT TD CPTS|1|APCL*BDM

 +78      ;;DM AUDIT TOBACCO HLTH FACTORS|0|APCL*BDM

 +79      ;;DM AUDIT GLITAZONE DRUGS|0|APCL*BDM

 +80      ;;DM AUDIT TYPE I DXS|1|APCL*BDM

 +81      ;;DM AUDIT TYPE II DXS|1|APCL*BDM

 +82      ;;DM AUDIT MICROALBUMIN LOINC CODES|1|APCL

 +83      ;;DM AUDIT URINALYSIS LOINC|1|APCL

 +84      ;;DM AUDIT URINE PROTEIN LOINC|1|APCL

 +85      ;;