- APCLP17 ; IHS/BJI/GRL - Routine to create bulletin [ 01/16/05 2:03 PM ]
- ;;3.0;IHS PCC REPORTS;**17**;FEB 15, 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
- ;
- 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","V3P17",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
- ;;
- APCLP17 ; IHS/BJI/GRL - Routine to create bulletin [ 01/16/05 2:03 PM ]
- +1 ;;3.0;IHS PCC REPORTS;**17**;FEB 15, 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 ;
- +28 ;delete out duplicate lab taxonomies
- DO DUPE
- +29 DO LAB
- +30 DO ^APCL1TX
- +31 DO ^APCL2TX
- +32 DO TAXREAD
- +33 ;rename DM AUDIT TROGLITIZONE TO GLITAZONE
- +34 SET ATXFLG=1
- +35 SET DA=$ORDER(^ATXAX("B","DM AUDIT TROGLITAZONE DRUGS",0))
- +36 IF DA
- SET DIE="^ATXAX("
- SET DR=".01///DM AUDIT GLITAZONE DRUGS"
- DO ^DIE
- DO ^XBFMK
- +37 ;ADD TAXONOMY TYPE FOR LOINC
- +38 DO ^XBFMK
- +39 SET APCLDA=$ORDER(^ATXTYPE("B","LOINC CODES",0))
- +40 IF 'APCLDA
- Begin DoDot:1
- +41 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
- +42 DO ^XBFMK
- KILL DIADD,DLAYGO
- +43 QUIT
- End DoDot:1
- +44 IF '$GET(DUZ)
- WRITE !,"DUZ UNDEFINED OR ZERO.",!
- QUIT
- +45 DO HOME^%ZIS
- DO DT^DICRW
- +46 ;
- +47 NEW XMSUB,XMDUZ,XMTEXT,XMY,DIFROM
- +48 KILL ^TMP($JOB,"APCLBUL")
- +49 DO WRITEMSG
- DO GETRECIP
- +50 ;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","V3P17",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 ;;