APCH2P16.m

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      ;;