APCLP18 ; IHS/BJI/GRL - Routine to create bulletin [ 01/16/05 2:03 PM ]
;;3.0;IHS PCC REPORTS;**18**;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*7") 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 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")
;
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","V3P18",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
;;
APCLP18 ; IHS/BJI/GRL - Routine to create bulletin [ 01/16/05 2:03 PM ]
+1 ;;3.0;IHS PCC REPORTS;**18**;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*7")
DO SORRY(2)
+7 QUIT
+8 ;
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 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 SET X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL M DV REPORTS","DVR")
+6 IF 'X
WRITE "Attempt to add DV REPORTS menu option failed.."
HANG 3
+7 SET X=$$ADD^XPDMENU("APCL M DX/PROC COUNT REPORTS","APCL OPERATING PROVIDER REPORT","TOP")
+8 IF 'X
WRITE "Attempt to add DV REPORTS menu option failed.."
HANG 3
+9 SET X=$$ADD^XPDMENU("APCL M MAN QUALITY ASSURANCE","APCL P RETURNS TO CLINIC","RT1")
+10 IF 'X
WRITE "Attempt to add RETURNS TO CLINIC report option failed.."
HANG 3
+11 SET X=$$ADD^XPDMENU("APCL M DX/PROC COUNT REPORTS","APCL P CPT BY PROVIDER","CPTP")
+12 IF 'X
WRITE "Attempt to add CPT BY PROVIDER REPORT menu option failed.."
HANG 3
+13 SET X=$$ADD^XPDMENU("APCL M MAN REPORTS BMI","APCL P BMI MOVE","MBC")
+14 IF 'X
WRITE "Attempt to add BMI MOVE menu option failed.."
HANG 3
+15 SET X=$$ADD^XPDMENU("APCL M MAIN DM MENU","APCL DM2005 AUDIT MENU","DM05",2)
+16 IF 'X
WRITE "Attempt to add 2005 DM AUDIT menu option failed.."
HANG 3
+17 SET X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL MENU SUICIDE REPORTS","SUIC")
+18 IF 'X
WRITE "Attempt to add SUICIDE REPORTS menu option failed.."
HANG 3
+19 SET X=$$ADD^XPDMENU("APCL M MAN ALL REPORTS","APCL P PCCV TALLY PROV/CLN","TPC")
+20 IF 'X
WRITE "Attempt to add TALLY BY PROV/CLINIC menu option failed.."
HANG 3
+21 SET X=$$ADD^XPDMENU("APCL M MAIN DM MENU","APCL DM SELF MONITORING","SMBG")
+22 IF 'X
WRITE "Attempt to add Self Monitoring Report failed.."
HANG 3
+23 SET X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL P PLST DECEASED PTS","DPL")
+24 IF 'X
WRITE "Attempt to add DECEASED PTS LISTING menu option failed.."
HANG 3
+25 SET X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL P PLST THI/NHH","THI")
+26 IF 'X
WRITE "Attempt to add TOTAL HOUSEHOLD INCOME LISTING menu option failed.."
HANG 3
+27 SET X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL M INFANT FEEDING","IF")
+28 IF 'X
WRITE "Attempt to add INFANT FEEDING REPORTS menu option failed.."
HANG 3
+29 SET APCLX="APCL P BILL THIRD PARTY"
SET APCLY="TPR"
+30 SET X=$$ADD^XPDMENU("APCL M MAN BILLING REPORTS",APCLX,APCLY)
+31 SET X=$$ADD^XPDMENU("APCLMENU","APCLLT CUSTOM LETTER MGT","CLM")
+32 SET X=$$ADD^XPDMENU("APCL M MAIN DM MENU","APCL DM2006 AUDIT MENU","DM06",1)
+33 IF 'X
WRITE "Attempt to add 2006 DM AUDIT menu option failed.."
HANG 3
+34 SET X=$$DELETE^XPDMENU("APCLMENU","APCL P DATA FETCHER")
+35 SET X=$$DELETE^XPDMENU("APCLMENU","APCL M REPORT TEMPLATE")
+36 SET X=$$DELETE^XPDMENU("APCLMENU","APCL P QA DELETE REP DEF")
+37 SET X=$$ADD^XPDMENU("APCLMENU","APCL M OTHER REPORTS","OTH")
+38 SET X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL P PRESCRIPTION COST","PCR")
+39 ;
+40 ;delete out duplicate lab taxonomies
DO DUPE
+41 DO LAB
+42 DO ^APCL1TX
+43 DO ^APCL2TX
+44 DO TAXREAD
+45 ;rename DM AUDIT TROGLITIZONE TO GLITAZONE
+46 SET ATXFLG=1
+47 SET DA=$ORDER(^ATXAX("B","DM AUDIT TROGLITAZONE DRUGS",0))
+48 IF DA
SET DIE="^ATXAX("
SET DR=".01///DM AUDIT GLITAZONE DRUGS"
DO ^DIE
DO ^XBFMK
+49 ;ADD TAXONOMY TYPE FOR LOINC
+50 DO ^XBFMK
+51 SET APCLDA=$ORDER(^ATXTYPE("B","LOINC CODES",0))
+52 IF 'APCLDA
Begin DoDot:1
+53 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
+54 DO ^XBFMK
KILL DIADD,DLAYGO
+55 QUIT
End DoDot:1
+56 IF '$GET(DUZ)
WRITE !,"DUZ UNDEFINED OR ZERO.",!
QUIT
+57 DO HOME^%ZIS
DO DT^DICRW
+58 ;
+59 NEW XMSUB,XMDUZ,XMTEXT,XMY,DIFROM
+60 KILL ^TMP($JOB,"APCLBUL")
+61 DO WRITEMSG
DO GETRECIP
+62 ;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","V3P18",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 ;;
