APCH2P16 ; IHS/TUCSON/LAB - PCC HEALTH SUMMARY POST INIT PATCH 12 ; [ 09/07/04 10:26 AM ]
;;2.0;IHS RPMS/PCC Health Summary;**16**;JUN 24, 1997
;
;
; The following line prevents the "Disable Options..." and "Move
; Routines..." questions from being asked during the install.
I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
F X="XPO1","XPZ1","XPZ2","XPI1" S XPDDIQ(X)=0
I '$$INSTALLD("APCH*2.0*15") D SORRY(2)
;
Q
INSTALLD(APCHSTAL) ;EP - Determine if patch APCHSTAL was installed, where
; APCHSTAL is the name of the INSTALL. E.g "AG*6.0*11".
;
NEW APCHY,DIC,X,Y
S X=$P(APCHSTAL,"*",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(APCHSTAL,"*",2)
D ^DIC
I Y<1 D IMES Q 0
S DIC=DIC_+Y_",""PAH"",",X=$P(APCHSTAL,"*",3)
D ^DIC
S APCHY=Y
D IMES
Q $S(APCHY<1:0,1:1)
IMES ;
D MES^XPDUTL($$CJ^XLFSTR("Patch """_APCHSTAL_""" 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
PRE ;EP
;SAVE OFF STATUS FOR EACH REMINDER
S DA=$O(^APCHHMC("B","CARDIOVASCULAR DISEASE",0))
I DA S DIE="^APCHHMC(",DR=".01///CVD-RELATED" D ^DIE
K DIE,DA,DR
S DA=$O(^APCHSURV("B","IHD-Elevated LDL Prompt",0))
I DA S DIE="^APCHSURV(",DR=".01///LDL Elevated for IHD Patients" D ^DIE
K DA,DR,DIE
S DA=$O(^APCHSURV("B","IHD-LDL Screening",0))
I DA S DIE="^APCHSURV(",DR=".01///LDL Screening for IHD Patients" D ^DIE
K DA,DR,DIE
S DA=$O(^APCHSURV("B","SCREEN FOR ALCOHOL USE",0))
I DA S DIE="^APCHSURV(",DR=".01///ALCOHOL USE SCREENING" D ^DIE
K DA,DR,DIE
S DA=$O(^APCHSURV("B","SCREEN FOR TOBACCO USE",0))
I DA S DIE="^APCHSURV(",DR=".01///TOBACCO USE SCREENING" D ^DIE
K DA,DR,DIE
K ^APCHTMP("HMR STATUS")
S X=0 F S X=$O(^APCHSURV(X)) Q:X'=+X S ^APCHTMP("HMR STATUS",X)=$P(^APCHSURV(X,0),U)_U_$P(^APCHSURV(X,0),U,3)
Q
POST ;EP
S X=$$ADD^XPDMENU("APCHSMAINT","APCH UPD MAJOR CPT TAX","IPT")
I 'X W "Attempt to add MAJOR CPT taxonomy option failed." H 3
S X=$$ADD^XPDMENU("APCHSMAINT","APCH UPD MINOR CPT TAX","MPT")
I 'X W "Attempt to add Minor CPT taxonomy option failed." H 3
I '$D(^ATXAX("B","APCH HS MAJOR PROCEDURE CPTS")) D ^APCHP16 ;2 NEW TAXONOMIES
S DA=$O(^ATXAX("B","APCH HS MAJOR PROCEDURE CPTS",0))
I DA S $P(^ATXAX(DA,0),U,4)="n"
S DA=$O(^ATXAX("B","APCH HS MINOR PROCEDURE CPTS",0))
I DA S $P(^ATXAX(DA,0),U,4)="n"
;PUT STATUS BACK IN
S APCHX=0 F S APCHX=$O(^APCHTMP("HMR STATUS",APCHX)) Q:APCHX'=+APCHX D
.S X=$P(^APCHTMP("HMR STATUS",APCHX),U),APCHS=$P(^APCHTMP("HMR STATUS",APCHX),U,2),DIC="^APCHSURV(",DIC(0)="M" D ^DIC
.I Y=-1 W !!,"could not update status on ",X," hmr" Q
.S $P(^APCHSURV(+Y,0),U,3)=APCHS
;update new categories per Linza Bethea 6/18/07
S APCHST="CAT" F APCHSX=1:1:999 S APCH1=$P($T(@APCHST+APCHSX),";;",2,99) Q:APCH1="" D
.K DIC S X=$P(APCH1,";;",1),DIC="^APCHSURV(",DIC(0)="M" D ^DIC K DIC
.I Y=-1 Q
.S DA=+Y,DR=".05///"_$P(APCH1,";;",2),DIE="^APCHSURV(" D ^DIE K DIE,DA,DR
.I $D(Y) W !,"category not updated. ",X
.Q
D TAXREAD
BUL ;
D ^APCHBU16
Q
TAXREAD ;
S ATXPNSP=""
S APCHTEXT="TAX" F APCHX=1:1 S APCHDATA=$P($T(@APCHTEXT+APCHX),";;",2) Q:APCHDATA="" D
.S APCHDA=$O(^ATXAX("B",$P(APCHDATA,"|"),0))
.Q:APCHDA=""
.S $P(^ATXAX(APCHDA,0),U,4)="n" W !,$P(APCHDATA,"|") ;SET NO DELETE
.S $P(^ATXAX(APCHDA,0),U,22)=$P(APCHDATA,"|",2) ;set read only
.;set packages in multiple
.K DIC,DA,DR
.S APCHP=$P(APCHDATA,"|",3)
.F APCHN=1:1 S APCHPP=$P(APCHP,"*",APCHN) Q:APCHPP="" D
..S APCHPI=$O(^DIC(9.4,"C",APCHPP,0))
..Q:APCHPI="" ;NO PACKAGE
..S X="`"_APCHPI,DIC="^ATXAX("_APCHDA_",41,",DIC(0)="L",DIC("P")=$P(^DD(9002226,4101,0),U,2),DA(1)=APCHDA
..D ^DIC
..I Y=-1 W !,"updating package multiple for ",APCHPP," entry ",$P(^ATXAX(APCHDA,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(APCHPNSP)
.I $E(Y,1,L)=APCHPNSP S $P(^ATXAX(X,0),U,4)="n" W !,Y
.Q
Q
TAX ;
;;APCH GLUCOSE SCREENING LOINC|1|APCH
;;APCH DM ADA EXAMS|0|APCH
;;APCH CLINIC STOP FOR PT HS|1|APCH
;;APCH HCT/HGB LOINC CODES|1|APCH
;;APCH ISCHEMIC HEART DISEASE|1|APCH
;;APCH PNEUMOVAX REVAX|1|APCH
;;APCH HS MINOR PROCEDURE CPTS|0|APCH
;;APCH HS MAJOR PROCEDURE CPTS|0|APCH
;;
CAT ;;
;;BREAST EXAM;;GENERAL
;;DIABETES SCREENING;;DIABETES
;;BLOOD PRESSURE;;GENERAL
;;PAP SMEAR;;CANCER
;;RECTAL;;CANCER
;;TONOMETRY;;ELDER
;;URINALYSIS;;PEDIATRIC
;;PELVIC EXAM;;GENERAL
;;VISUAL ACUITY EXAM;;ELDER
;;HEARING TEST;;PEDIATRIC
;;HCT/HGB;;PEDIATRIC
;;HEAD CIRCUMFERENCE;;PEDIATRIC
;;HEIGHT;;GENERAL
;;WEIGHT;;GENERAL
;;IMMUNIZATIONS;;IMMUNIZATIONS
;;MAMMOGRAM;;CANCER
;;PNEUMOVAX;;IMMUNIZATIONS
;;SCREEN FOR ALCOHOL USE;;BEHAVIORAL HEALTH
;;SCREEN FOR TOBACCO USE;;CANCER
;;PHYSICAL EXAM;;GENERAL
;;TD-ADULT;;IMMUNIZATIONS
;;INFLUENZA;;IMMUNIZATIONS
;;COLORECTAL CA SCRN-FOBT;;CANCER
;;CHOLESTEROL;;CVD-RELATED
;;COLORECTAL CA-SCOPE/XRAY;;CANCER
;;HEARING INQUIRY;;ELDER
;;STRABISMUS/AMBLYOPIA SCREEN;;PEDIATRIC
;;PPD - TUBERCULOSIS;;PEDIATRIC
;;ANMC DEPRESSION SCREEN SCORE;;BEHAVIORAL HEALTH
;;REHAB/FUNCTIONAL SCREEN;;GENERAL
;;ANMC COLORECTAL;;CANCER
;;ASTHMA - ADD/INCREASE INHALED STERIODS;;ASTHMA
;;ASTHMA - PRIMARY CARE PROVIDER;;ASTHMA
;;ASTHMA - SEVERITY CLASSIFICATION;;ASTHMA
;;ASTHMA - MANAGEMENT PLAN;;ASTHMA
;;ASTHMA PATIENT-FLU SHOT;;IMMUNIZATIONS
;;IHD-LDL Screening;;CVD-RELATED
;;IHD-Elevated LDL Prompt;;CVD-RELATED
;;ADULT MMR 1-DOSE VERSION;;IMMUNIZATIONS
;;ADULT MMR 2-DOSE VERSION;;IMMUNIZATIONS
;;RUBELLA VACCINATION;;IMMUNIZATIONS
;;DOMESTIC VIOLENCE/IPV SCREENING;;BEHAVIORAL HEALTH
;;ANMC COLORECTAL CANCER;;CANCER
;;DEPRESSION SCREENING;;BEHAVIORAL HEALTH
;;FALL RISK ASSESSMENT;;ELDER
;;EPSDT Screening;;PEDIATRIC
;;
;;
APCH2P16 ; IHS/TUCSON/LAB - PCC HEALTH SUMMARY POST INIT PATCH 12 ; [ 09/07/04 10:26 AM ]
+1 ;;2.0;IHS RPMS/PCC Health Summary;**16**;JUN 24, 1997
+2 ;
+3 ;
+4 ; The following line prevents the "Disable Options..." and "Move
+5 ; Routines..." questions from being asked during the install.
+6 IF $GET(XPDENV)=1
SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
+7 FOR X="XPO1","XPZ1","XPZ2","XPI1"
SET XPDDIQ(X)=0
+8 IF '$$INSTALLD("APCH*2.0*15")
DO SORRY(2)
+9 ;
+10 QUIT
INSTALLD(APCHSTAL) ;EP - Determine if patch APCHSTAL was installed, where
+1 ; APCHSTAL is the name of the INSTALL. E.g "AG*6.0*11".
+2 ;
+3 NEW APCHY,DIC,X,Y
+4 SET X=$PIECE(APCHSTAL,"*",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(APCHSTAL,"*",2)
+9 DO ^DIC
+10 IF Y<1
DO IMES
QUIT 0
+11 SET DIC=DIC_+Y_",""PAH"","
SET X=$PIECE(APCHSTAL,"*",3)
+12 DO ^DIC
+13 SET APCHY=Y
+14 DO IMES
+15 QUIT $SELECT(APCHY<1:0,1:1)
IMES ;
+1 DO MES^XPDUTL($$CJ^XLFSTR("Patch """_APCHSTAL_""" 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
PRE ;EP
+1 ;SAVE OFF STATUS FOR EACH REMINDER
+2 SET DA=$ORDER(^APCHHMC("B","CARDIOVASCULAR DISEASE",0))
+3 IF DA
SET DIE="^APCHHMC("
SET DR=".01///CVD-RELATED"
DO ^DIE
+4 KILL DIE,DA,DR
+5 SET DA=$ORDER(^APCHSURV("B","IHD-Elevated LDL Prompt",0))
+6 IF DA
SET DIE="^APCHSURV("
SET DR=".01///LDL Elevated for IHD Patients"
DO ^DIE
+7 KILL DA,DR,DIE
+8 SET DA=$ORDER(^APCHSURV("B","IHD-LDL Screening",0))
+9 IF DA
SET DIE="^APCHSURV("
SET DR=".01///LDL Screening for IHD Patients"
DO ^DIE
+10 KILL DA,DR,DIE
+11 SET DA=$ORDER(^APCHSURV("B","SCREEN FOR ALCOHOL USE",0))
+12 IF DA
SET DIE="^APCHSURV("
SET DR=".01///ALCOHOL USE SCREENING"
DO ^DIE
+13 KILL DA,DR,DIE
+14 SET DA=$ORDER(^APCHSURV("B","SCREEN FOR TOBACCO USE",0))
+15 IF DA
SET DIE="^APCHSURV("
SET DR=".01///TOBACCO USE SCREENING"
DO ^DIE
+16 KILL DA,DR,DIE
+17 KILL ^APCHTMP("HMR STATUS")
+18 SET X=0
FOR
SET X=$ORDER(^APCHSURV(X))
IF X'=+X
QUIT
SET ^APCHTMP("HMR STATUS",X)=$PIECE(^APCHSURV(X,0),U)_U_$PIECE(^APCHSURV(X,0),U,3)
+19 QUIT
POST ;EP
+1 SET X=$$ADD^XPDMENU("APCHSMAINT","APCH UPD MAJOR CPT TAX","IPT")
+2 IF 'X
WRITE "Attempt to add MAJOR CPT taxonomy option failed."
HANG 3
+3 SET X=$$ADD^XPDMENU("APCHSMAINT","APCH UPD MINOR CPT TAX","MPT")
+4 IF 'X
WRITE "Attempt to add Minor CPT taxonomy option failed."
HANG 3
+5 ;2 NEW TAXONOMIES
IF '$DATA(^ATXAX("B","APCH HS MAJOR PROCEDURE CPTS"))
DO ^APCHP16
+6 SET DA=$ORDER(^ATXAX("B","APCH HS MAJOR PROCEDURE CPTS",0))
+7 IF DA
SET $PIECE(^ATXAX(DA,0),U,4)="n"
+8 SET DA=$ORDER(^ATXAX("B","APCH HS MINOR PROCEDURE CPTS",0))
+9 IF DA
SET $PIECE(^ATXAX(DA,0),U,4)="n"
+10 ;PUT STATUS BACK IN
+11 SET APCHX=0
FOR
SET APCHX=$ORDER(^APCHTMP("HMR STATUS",APCHX))
IF APCHX'=+APCHX
QUIT
Begin DoDot:1
+12 SET X=$PIECE(^APCHTMP("HMR STATUS",APCHX),U)
SET APCHS=$PIECE(^APCHTMP("HMR STATUS",APCHX),U,2)
SET DIC="^APCHSURV("
SET DIC(0)="M"
DO ^DIC
+13 IF Y=-1
WRITE !!,"could not update status on ",X," hmr"
QUIT
+14 SET $PIECE(^APCHSURV(+Y,0),U,3)=APCHS
End DoDot:1
+15 ;update new categories per Linza Bethea 6/18/07
+16 SET APCHST="CAT"
FOR APCHSX=1:1:999
SET APCH1=$PIECE($TEXT(@APCHST+APCHSX),";;",2,99)
IF APCH1=""
QUIT
Begin DoDot:1
+17 KILL DIC
SET X=$PIECE(APCH1,";;",1)
SET DIC="^APCHSURV("
SET DIC(0)="M"
DO ^DIC
KILL DIC
+18 IF Y=-1
QUIT
+19 SET DA=+Y
SET DR=".05///"_$PIECE(APCH1,";;",2)
SET DIE="^APCHSURV("
DO ^DIE
KILL DIE,DA,DR
+20 IF $DATA(Y)
WRITE !,"category not updated. ",X
+21 QUIT
End DoDot:1
+22 DO TAXREAD
BUL ;
+1 DO ^APCHBU16
+2 QUIT
TAXREAD ;
+1 SET ATXPNSP=""
+2 SET APCHTEXT="TAX"
FOR APCHX=1:1
SET APCHDATA=$PIECE($TEXT(@APCHTEXT+APCHX),";;",2)
IF APCHDATA=""
QUIT
Begin DoDot:1
+3 SET APCHDA=$ORDER(^ATXAX("B",$PIECE(APCHDATA,"|"),0))
+4 IF APCHDA=""
QUIT
+5 ;SET NO DELETE
SET $PIECE(^ATXAX(APCHDA,0),U,4)="n"
WRITE !,$PIECE(APCHDATA,"|")
+6 ;set read only
SET $PIECE(^ATXAX(APCHDA,0),U,22)=$PIECE(APCHDATA,"|",2)
+7 ;set packages in multiple
+8 KILL DIC,DA,DR
+9 SET APCHP=$PIECE(APCHDATA,"|",3)
+10 FOR APCHN=1:1
SET APCHPP=$PIECE(APCHP,"*",APCHN)
IF APCHPP=""
QUIT
Begin DoDot:2
+11 SET APCHPI=$ORDER(^DIC(9.4,"C",APCHPP,0))
+12 ;NO PACKAGE
IF APCHPI=""
QUIT
+13 SET X="`"_APCHPI
SET DIC="^ATXAX("_APCHDA_",41,"
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(9002226,4101,0),U,2)
SET DA(1)=APCHDA
+14 DO ^DIC
+15 IF Y=-1
WRITE !,"updating package multiple for ",APCHPP," entry ",$PIECE(^ATXAX(APCHDA,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(APCHPNSP)
+4 IF $EXTRACT(Y,1,L)=APCHPNSP
SET $PIECE(^ATXAX(X,0),U,4)="n"
WRITE !,Y
+5 QUIT
End DoDot:1
+6 QUIT
TAX ;
+1 ;;APCH GLUCOSE SCREENING LOINC|1|APCH
+2 ;;APCH DM ADA EXAMS|0|APCH
+3 ;;APCH CLINIC STOP FOR PT HS|1|APCH
+4 ;;APCH HCT/HGB LOINC CODES|1|APCH
+5 ;;APCH ISCHEMIC HEART DISEASE|1|APCH
+6 ;;APCH PNEUMOVAX REVAX|1|APCH
+7 ;;APCH HS MINOR PROCEDURE CPTS|0|APCH
+8 ;;APCH HS MAJOR PROCEDURE CPTS|0|APCH
+9 ;;
CAT ;;
+1 ;;BREAST EXAM;;GENERAL
+2 ;;DIABETES SCREENING;;DIABETES
+3 ;;BLOOD PRESSURE;;GENERAL
+4 ;;PAP SMEAR;;CANCER
+5 ;;RECTAL;;CANCER
+6 ;;TONOMETRY;;ELDER
+7 ;;URINALYSIS;;PEDIATRIC
+8 ;;PELVIC EXAM;;GENERAL
+9 ;;VISUAL ACUITY EXAM;;ELDER
+10 ;;HEARING TEST;;PEDIATRIC
+11 ;;HCT/HGB;;PEDIATRIC
+12 ;;HEAD CIRCUMFERENCE;;PEDIATRIC
+13 ;;HEIGHT;;GENERAL
+14 ;;WEIGHT;;GENERAL
+15 ;;IMMUNIZATIONS;;IMMUNIZATIONS
+16 ;;MAMMOGRAM;;CANCER
+17 ;;PNEUMOVAX;;IMMUNIZATIONS
+18 ;;SCREEN FOR ALCOHOL USE;;BEHAVIORAL HEALTH
+19 ;;SCREEN FOR TOBACCO USE;;CANCER
+20 ;;PHYSICAL EXAM;;GENERAL
+21 ;;TD-ADULT;;IMMUNIZATIONS
+22 ;;INFLUENZA;;IMMUNIZATIONS
+23 ;;COLORECTAL CA SCRN-FOBT;;CANCER
+24 ;;CHOLESTEROL;;CVD-RELATED
+25 ;;COLORECTAL CA-SCOPE/XRAY;;CANCER
+26 ;;HEARING INQUIRY;;ELDER
+27 ;;STRABISMUS/AMBLYOPIA SCREEN;;PEDIATRIC
+28 ;;PPD - TUBERCULOSIS;;PEDIATRIC
+29 ;;ANMC DEPRESSION SCREEN SCORE;;BEHAVIORAL HEALTH
+30 ;;REHAB/FUNCTIONAL SCREEN;;GENERAL
+31 ;;ANMC COLORECTAL;;CANCER
+32 ;;ASTHMA - ADD/INCREASE INHALED STERIODS;;ASTHMA
+33 ;;ASTHMA - PRIMARY CARE PROVIDER;;ASTHMA
+34 ;;ASTHMA - SEVERITY CLASSIFICATION;;ASTHMA
+35 ;;ASTHMA - MANAGEMENT PLAN;;ASTHMA
+36 ;;ASTHMA PATIENT-FLU SHOT;;IMMUNIZATIONS
+37 ;;IHD-LDL Screening;;CVD-RELATED
+38 ;;IHD-Elevated LDL Prompt;;CVD-RELATED
+39 ;;ADULT MMR 1-DOSE VERSION;;IMMUNIZATIONS
+40 ;;ADULT MMR 2-DOSE VERSION;;IMMUNIZATIONS
+41 ;;RUBELLA VACCINATION;;IMMUNIZATIONS
+42 ;;DOMESTIC VIOLENCE/IPV SCREENING;;BEHAVIORAL HEALTH
+43 ;;ANMC COLORECTAL CANCER;;CANCER
+44 ;;DEPRESSION SCREENING;;BEHAVIORAL HEALTH
+45 ;;FALL RISK ASSESSMENT;;ELDER
+46 ;;EPSDT Screening;;PEDIATRIC
+47 ;;
+48 ;;
