Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCLP18

APCLP18.m

Go to the documentation of this file. 
  1. APCLP18 ; IHS/BJI/GRL - Routine to create bulletin  [ 01/16/05  2:03 PM ]
  1.  ;;3.0;IHS PCC REPORTS;**18**;FEB 05, 1997
  1.  ;;
  1.  ; The following line prevents the "Disable Options..." and "Move
  1.  ; Routines..." questions from being asked during the install.
  1.  F X="XPO1","XPZ1","XPZ2","XPI1" S XPDDIQ(X)=0
  1.  I '$$INSTALLD("ATX*5.1*7") D SORRY(2)
  1.  Q
  1.  ;
  1. PRE ;EP
  1.  F DA=1:1:900 S DIK="^APCLVSTS(" D ^DIK
  1.  ;kill off lister entries
  1.  F DA=1:1:40 S DIK="^APCLRECD(" D ^DIK
  1.  F DA=1:1:10 S DIK="^APCLDMTX(" D ^DIK
  1.  F DA=1:1:40 S DIK="^APCLBMI(" D ^DIK
  1.  F DA=1:1:40 S DIK="^APCLCNTL(" D ^DIK
  1.  F DA=1:1:20 S DIK="^APCLPDES(" D ^DIK
  1.  K ^APCLBMI("H")
  1.  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
  1.  Q
  1. POST ;EP
  1. OPT ;add new options
  1.  NEW X
  1.  S X=$$ADD^XPDMENU("APCL M MAN QUALITY ASSURANCE","APCL P REFUSAL LIST","REF")
  1.  I 'X W "Attempt to add PATIENT REFUSAL LIST report option failed.." H 3
  1.  S X=$$DELETE^XPDMENU("APCL M MAN APC REPORTS/PCC","APCL P APC DX")
  1.  S X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL M DV REPORTS","DVR")
  1.  I 'X W "Attempt to add DV REPORTS menu option failed.." H 3
  1.  S X=$$ADD^XPDMENU("APCL M DX/PROC COUNT REPORTS","APCL OPERATING PROVIDER REPORT","TOP")
  1.  I 'X W "Attempt to add DV REPORTS menu option failed.." H 3
  1.  S X=$$ADD^XPDMENU("APCL M MAN QUALITY ASSURANCE","APCL P RETURNS TO CLINIC","RT1")
  1.  I 'X W "Attempt to add RETURNS TO CLINIC report option failed.." H 3
  1.  S X=$$ADD^XPDMENU("APCL M DX/PROC COUNT REPORTS","APCL P CPT BY PROVIDER","CPTP")
  1.  I 'X W "Attempt to add CPT BY PROVIDER REPORT menu option failed.." H 3
  1.  S X=$$ADD^XPDMENU("APCL M MAN REPORTS BMI","APCL P BMI MOVE","MBC")
  1.  I 'X W "Attempt to add BMI MOVE menu option failed.." H 3
  1.  S X=$$ADD^XPDMENU("APCL M MAIN DM MENU","APCL DM2005 AUDIT MENU","DM05",2)
  1.  I 'X W "Attempt to add 2005 DM AUDIT menu option failed.." H 3
  1.  S X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL MENU SUICIDE REPORTS","SUIC")
  1.  I 'X W "Attempt to add SUICIDE REPORTS menu option failed.." H 3
  1.  S X=$$ADD^XPDMENU("APCL M MAN ALL REPORTS","APCL P PCCV TALLY PROV/CLN","TPC")
  1.  I 'X W "Attempt to add TALLY BY PROV/CLINIC menu option failed.." H 3
  1.  S X=$$ADD^XPDMENU("APCL M MAIN DM MENU","APCL DM SELF MONITORING","SMBG")
  1.  I 'X W "Attempt to add Self Monitoring Report failed.." H 3
  1.  S X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL P PLST DECEASED PTS","DPL")
  1.  I 'X W "Attempt to add DECEASED PTS LISTING menu option failed.." H 3
  1.  S X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL P PLST THI/NHH","THI")
  1.  I 'X W "Attempt to add TOTAL HOUSEHOLD INCOME LISTING menu option failed.." H 3
  1.  S X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL M INFANT FEEDING","IF")
  1.  I 'X W "Attempt to add INFANT FEEDING REPORTS menu option failed.." H 3
  1.  S APCLX="APCL P BILL THIRD PARTY",APCLY="TPR"
  1.  S X=$$ADD^XPDMENU("APCL M MAN BILLING REPORTS",APCLX,APCLY)
  1.  S X=$$ADD^XPDMENU("APCLMENU","APCLLT CUSTOM LETTER MGT","CLM")
  1.  S X=$$ADD^XPDMENU("APCL M MAIN DM MENU","APCL DM2006 AUDIT MENU","DM06",1)
  1.  I 'X W "Attempt to add 2006 DM AUDIT menu option failed.." H 3
  1.  S X=$$DELETE^XPDMENU("APCLMENU","APCL P DATA FETCHER")
  1.  S X=$$DELETE^XPDMENU("APCLMENU","APCL M REPORT TEMPLATE")
  1.  S X=$$DELETE^XPDMENU("APCLMENU","APCL P QA DELETE REP DEF")
  1.  S X=$$ADD^XPDMENU("APCLMENU","APCL M OTHER REPORTS","OTH")
  1.  S X=$$ADD^XPDMENU("APCL M MAN PATIENT LISTINGS","APCL P PRESCRIPTION COST","PCR")
  1.  ;
  1.  D DUPE  ;delete out duplicate lab taxonomies
  1.  D LAB
  1.  D ^APCL1TX
  1.  D ^APCL2TX
  1.  D TAXREAD
  1.  ;rename DM AUDIT TROGLITIZONE TO GLITAZONE
  1.  S ATXFLG=1
  1.  S DA=$O(^ATXAX("B","DM AUDIT TROGLITAZONE DRUGS",0))
  1.  I DA S DIE="^ATXAX(",DR=".01///DM AUDIT GLITAZONE DRUGS" D ^DIE,^XBFMK
  1.  ;ADD TAXONOMY TYPE FOR LOINC
  1.  D ^XBFMK
  1.  S APCLDA=$O(^ATXTYPE("B","LOINC CODES",0))
  1.  I 'APCLDA D
  1.  .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
  1.  .D ^XBFMK K DIADD,DLAYGO
  1.  .Q
  1.  I '$G(DUZ) W !,"DUZ UNDEFINED OR ZERO.",! Q
  1.  D HOME^%ZIS,DT^DICRW
  1.  ;
  1.  NEW XMSUB,XMDUZ,XMTEXT,XMY,DIFROM
  1.  KILL ^TMP($J,"APCLBUL")
  1.  D WRITEMSG,GETRECIP
  1.  ;Change following lines as desired
  1. SUBJECT S XMSUB="* * * IMPORTANT RPMS INFORMATION * * *"
  1. SENDER S XMDUZ="Cimarron Medical Informatics"
  1.  S XMTEXT="^TMP($J,""APCLBUL"",",XMY(1)="",XMY(DUZ)=""
  1.  I $E(IOST)="C" W !,"Sending Mailman message to holders of the"_" "_APCLKEY_" "_"security key."
  1.  D ^XMD
  1.  KILL ^TMP($J,"APCLBUL"),APCLKEY
  1.  Q
  1.  ;
  1. WRITEMSG ;
  1.  S X=$O(^APCLPDES("B","V3P18",0))
  1.  Q:'X
  1.  S Y=0 F  S Y=$O(^APCLPDES(X,11,Y)) Q:Y'=+Y  S ^TMP($J,"APCLBUL",Y)=^APCLPDES(X,11,Y,0)
  1.  Q
  1.  ;
  1. GETRECIP ;
  1.  ;* * * Define key below to identify recipients * * *
  1.  ;
  1.  S CTR=0,APCLKEY="APCLZMENU"
  1.  F  S CTR=$O(^XUSEC(APCLKEY,CTR)) Q:'CTR  S Y=CTR S XMY(Y)=""
  1.  Q
  1. DUPE ;
  1.  S (APCLX,APCLC)=0 F  S APCLX=$O(^ATXLAB("B","DM AUDIT FASTING GLUCOSE TESTS",APCLX)) Q:APCLX'=+APCLX  S APCLC=APCLC+1 D
  1.  .Q:APCLC=1
  1.  .S DA=APCLX,DIK="^ATXLAB(" D ^DIK
  1.  .Q
  1.  S (APCLX,APCLC)=0 F  S APCLX=$O(^ATXLAB("B","DM AUDIT 75GM 2HR GLUCOSE",APCLX)) Q:APCLX'=+APCLX  S APCLC=APCLC+1 D
  1.  .Q:APCLC=1
  1.  .S DA=APCLX,DIK="^ATXLAB(" D ^DIK
  1.  .Q
  1.  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
  1.  .Q:APCLC=1
  1.  .S DA=APCLX,DIK="^ATXLAB(" D ^DIK
  1.  .Q
  1.  Q
  1. LAB ;
  1.  S APCLX="DM AUDIT FASTING GLUCOSE TESTS" D LAB1
  1.  S APCLX="DM AUDIT 75GM 2HR GLUCOSE" D LAB1
  1.  S APCLX="DM AUDIT A/C RATIO TAX" D LAB1
  1.  Q
  1. LAB1 ;
  1.  S APCLDA=$O(^ATXLAB("B",APCLX,0))
  1.  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
  1.  W !,"Creating ",APCLX," Taxonomy..."
  1.  S X=APCLX,DIC="^ATXLAB(",DIC(0)="L",DIADD=1,DLAYGO=9002228 D ^DIC K DIC,DA,DIADD,DLAYGO,I
  1.  I Y=-1 W !!,"ERROR IN CREATING ",APCLX," TAX" Q
  1.  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"
  1.  S DA=APCLTX,DIK="^ATXAX(" D IX1^DIK
  1.  Q
  1. SETTAXL ;
  1.  Q:'$D(^DD(9002228,4101,0))  ;taxonomy patch not yet installed
  1.  S APCLTEXT="LABTAX" F APCLX=1:1 S APCLDATA=$P($T(@APCLTEXT+APCLX),";;",2) Q:APCLDATA=""  D
  1.  .S APCLDA=$O(^ATXLAB("B",$P(APCLDATA,"|"),0))
  1.  .Q:APCLDA=""
  1.  .S $P(^ATXLAB(APCLDA,0),U,4)="n" W !,$P(APCLDATA,"|")  ;SET NO DELETE
  1.  .S $P(^ATXLAB(APCLDA,0),U,22)=$P(APCLDATA,"|",2) ;set read only
  1.  .;set packages in multiple
  1.  .K DIC,DA,DR
  1.  .S APCLP=$P(APCLDATA,"|",3)
  1.  .F APCLN=1:1 S APCLPP=$P(APCLP,"*",APCLN) Q:APCLPP=""  D
  1.  ..S APCLPI=$O(^DIC(9.4,"C",APCLPP,0))
  1.  ..Q:APCLPI=""  ;NO PACKAGE
  1.  ..S X="`"_APCLPI,DIC="^ATXLAB("_APCLDA_",41,",DIC(0)="L",DIC("P")=$P(^DD(9002228,4101,0),U,2),DA(1)=APCLDA
  1.  ..D ^DIC
  1.  ..I Y=-1 W !,"updating package multiple for ",APCLPP," entry ",$P(^ATXLAB(APCLDA,0),U)," failed"
  1.  ..K DIC,DA,Y,X
  1.  .Q
  1.  Q
  1. INSTALLD(APCLSTAL) ;EP - Determine if patch APCLSTAL was installed, where
  1.  ; APCLSTAL is the name of the INSTALL.  E.g "AG*6.0*11".
  1.  ;
  1.  NEW APCLY,DIC,X,Y
  1.  S X=$P(APCLSTAL,"*",1)
  1.  S DIC="^DIC(9.4,",DIC(0)="FM",D="C"
  1.  D IX^DIC
  1.  I Y<1 D IMES Q 0
  1.  S DIC=DIC_+Y_",22,",X=$P(APCLSTAL,"*",2)
  1.  D ^DIC
  1.  I Y<1 D IMES Q 0
  1.  S DIC=DIC_+Y_",""PAH"",",X=$P(APCLSTAL,"*",3)
  1.  D ^DIC
  1.  S APCLY=Y
  1.  D IMES
  1.  Q $S(APCLY<1:0,1:1)
  1. IMES ;
  1.  D MES^XPDUTL($$CJ^XLFSTR("Patch """_APCLSTAL_""" is"_$S(Y<1:" *NOT*",1:"")_" installed.",IOM))
  1.  Q
  1. SORRY(X) ;
  1.  KILL DIFQ
  1.  I X=3 S XPDQUIT=2 Q
  1.  S XPDQUIT=X
  1.  W *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
  1.  Q
  1. LABTAX ;
  1.  ;;DM AUDIT FASTING GLUCOSE TESTS|0|APCL
  1.  ;;DM AUDIT 75GM 2HR GLUCOSE|0|APCL
  1.  ;;
  1. TAXREAD ;
  1.  S ATXPNSP=""
  1.  S APCLTEXT="TAX" F APCLX=1:1 S APCLDATA=$P($T(@APCLTEXT+APCLX),";;",2) Q:APCLDATA=""  D
  1.  .S APCLDA=$O(^ATXAX("B",$P(APCLDATA,"|"),0))
  1.  .Q:APCLDA=""
  1.  .S $P(^ATXAX(APCLDA,0),U,4)="n" W !,$P(APCLDATA,"|")  ;SET NO DELETE
  1.  .S $P(^ATXAX(APCLDA,0),U,22)=$P(APCLDATA,"|",2) ;set read only
  1.  .;set packages in multiple
  1.  .K DIC,DA,DR
  1.  .S APCLP=$P(APCLDATA,"|",3)
  1.  .F APCLN=1:1 S APCLPP=$P(APCLP,"*",APCLN) Q:APCLPP=""  D
  1.  ..S APCLPI=$O(^DIC(9.4,"C",APCLPP,0))
  1.  ..Q:APCLPI=""  ;NO PACKAGE
  1.  ..S X="`"_APCLPI,DIC="^ATXAX("_APCLDA_",41,",DIC(0)="L",DIC("P")=$P(^DD(9002226,4101,0),U,2),DA(1)=APCLDA
  1.  ..D ^DIC
  1.  ..I Y=-1 W !,"updating package multiple for ",APCLPP," entry ",$P(^ATXAX(APCLDA,0),U)," failed"
  1.  ..K DIC,DA,Y,X
  1.  .Q
  1.  Q
  1. SET ;
  1.  S X=0 F  S X=$O(^ATXAX(X)) Q:X'=+X  D
  1.  .S Y=$P(^ATXAX(X,0),U)
  1.  .S L=$L(APCLPNSP)
  1.  .I $E(Y,1,L)=APCLPNSP S $P(^ATXAX(X,0),U,4)="n" W !,Y
  1.  .Q
  1.  Q
  1. TAX ;
  1.  ;;APCL CAR CNM|0|APCL
  1.  ;;APCL CAR DENTISTS|0|APCL
  1.  ;;APCL CAR FNP|0|APCL
  1.  ;;APCL CAR LCSW|0|APCL
  1.  ;;APCL CAR LVN|0|APCL
  1.  ;;APCL CAR OTHER PROVIDERS|0|APCL
  1.  ;;APCL CAR OTHER2|0|APCL
  1.  ;;APCL CAR PA|0|APCL
  1.  ;;APCL CAR PHYSICIANS|0|APCL
  1.  ;;APCL CAR PSYCHIATRIST|0|APCL
  1.  ;;APCL CAR PSYCHOLOGIST|0|APCL
  1.  ;;APCL CAR PT ED|0|APCL
  1.  ;;APCL CAR RDA|0|APCL
  1.  ;;APCL CAR RN|0|APCL
  1.  ;;APCL DIABETES REG COMPLICATION|0|APCL*BDM
  1.  ;;APCL DIABETES REG NEW CASE|0|APCL*BDM
  1.  ;;APCL HRSA TABLE 6 LINE 16|1
  1.  ;;APCL HRSA TABLE 6 LINE 17|1
  1.  ;;APCL HRSA TABLE 6 LINE 20|1
  1.  ;;APCL INJ AIR TRANSPORT|1|APCL
  1.  ;;APCL INJ ANIMAL RELATED|1|APCL
  1.  ;;APCL INJ ASSAULTS|1|APCL
  1.  ;;APCL INJ BATTERED CHILD|1|APCL
  1.  ;;APCL INJ CUT|1|APCL
  1.  ;;APCL INJ DROWNING|1|APCL
  1.  ;;APCL INJ ENVIRONMENTAL FACTORS|1|APCL
  1.  ;;APCL INJ FALLS|1|APCL
  1.  ;;APCL INJ FIRE|1|APCL
  1.  ;;APCL INJ FIREARMS|1|APCL
  1.  ;;APCL INJ MOTOR|1|APCL
  1.  ;;APCL INJ OTHER CAUSES|1|APCL
  1.  ;;APCL INJ POISONING|1|APCL
  1.  ;;APCL INJ SPORTS|1|APCL
  1.  ;;APCL INJ STINGS VENOMS|1|APCL
  1.  ;;APCL INJ SUICIDE|1|APCL
  1.  ;;APCL INJ UNDETERMINED|1|APCL
  1.  ;;APCL INJ WATER TRANSPORT|1|APCL
  1.  ;;DM AUDIT 75GM 2HR LOINC|1|APCL*APCH
  1.  ;;DM AUDIT A/C RATIO LOINC|1|APCL
  1.  ;;DM AUDIT ACARBOSE DRUGS|0|APCL*BDM
  1.  ;;DM AUDIT ACE INHIBITORS|0|APCL*BDM
  1.  ;;DM AUDIT ANTI-PLATELET DRUGS|0|APCL*BDM
  1.  ;;DM AUDIT ASPIRIN DRUGS|0|APCL*BDM
  1.  ;;DM AUDIT CESSATION HLTH FACTOR|0|APCL*BDM
  1.  ;;DM AUDIT DENTAL EXAM ADA CODES|0|APCL*BDM
  1.  ;;DM AUDIT DEPRESSIVE DISORDERS|1|APCL*BDM
  1.  ;;DM AUDIT DIABETES EDUC TOPICS|0|APCL*BDM
  1.  ;;DM AUDIT DIET EDUC TOPICS|0|APCL*BDM
  1.  ;;DM AUDIT EKG CPTS|1|APCL*BDM
  1.  ;;DM AUDIT ESTIMATED GFR LOINC|1|APCL*APCH
  1.  ;;DM AUDIT EXCERCISE EDUC TOPICS|0|APCL
  1.  ;;DM AUDIT EXERCISE EDUC TOPICS|0|APCL
  1.  ;;DM AUDIT EYE EXAM DXS|1|APCL*BDM
  1.  ;;DM AUDIT FASTING GLUC LOINC|1|APCL*APCH
  1.  ;;DM AUDIT FLU CPTS|1|APCL*BDM
  1.  ;;DM AUDIT INSULIN DRUGS|0|APCL*BDM
  1.  ;;DM AUDIT LIPID LOWERING DRUGS|0|APCL*BDM
  1.  ;;DM AUDIT MAMMOGRAM CPTS|1|APCL*BDM
  1.  ;;DM AUDIT METFORMIN DRUGS|0|APCL*BDM
  1.  ;;DM AUDIT ORAL HYPOGLYCEMICS|0|APCL*BDM
  1.  ;;DM AUDIT OTHER EDUC TOPICS|0|APCL*BDM
  1.  ;;DM AUDIT PAP CPTS|1|APCL*BDM
  1.  ;;DM AUDIT PERIDONTAL ADA CODES|0|APCL*BDM
  1.  ;;DM AUDIT PNEUMO CPTS|1|APCL*BDM
  1.  ;;DM AUDIT PRE-DIABETES DXS|1|APCL*BDM*APCH
  1.  ;;DM AUDIT PROBLEM DIABETES DX|1|APCL*BDM
  1.  ;;DM AUDIT PROBLEM HTN DIAGNOSES|1|APCL*BDM
  1.  ;;DM AUDIT PROBLEM SMOKING DXS|1|APCL*BDM
  1.  ;;DM AUDIT PROBLEM TB DXS|1|APCL*BDM
  1.  ;;DM AUDIT SDM PROVIDERS|0|APCL*BDM
  1.  ;;DM AUDIT SELF MONITOR DRUGS|0|APCL*BDM
  1.  ;;DM AUDIT SMOKING CESS EDUC|0|APCL*BDM
  1.  ;;DM AUDIT SMOKING RELATED DXS|1|APCL*BDM
  1.  ;;DM AUDIT STATIN DRUGS|0|APCL*BDM
  1.  ;;DM AUDIT SULFONYLUREA DRUGS|0|APCL*BDM
  1.  ;;DM AUDIT TB HEALTH FACTORS|0|APCL*BDM
  1.  ;;DM AUDIT TD CPTS|1|APCL*BDM
  1.  ;;DM AUDIT TOBACCO HLTH FACTORS|0|APCL*BDM
  1.  ;;DM AUDIT GLITAZONE DRUGS|0|APCL*BDM
  1.  ;;DM AUDIT TYPE I DXS|1|APCL*BDM
  1.  ;;DM AUDIT TYPE II DXS|1|APCL*BDM
  1.  ;;DM AUDIT MICROALBUMIN LOINC CODES|1|APCL
  1.  ;;DM AUDIT URINALYSIS LOINC|1|APCL
  1.  ;;DM AUDIT URINE PROTEIN LOINC|1|APCL
  1.  ;;