APCH2P11.m

APCH2P11 ; IHS/TUCSON/LAB - PCC HEALTH SUMMARY POST INIT PATCH 11 ;  [ 04/14/04  3:14 PM ]

 ;;2.0;IHS RPMS/PCC Health Summary;**11**;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

 ;

 Q

PRE ;EP

 S DA=$O(^APCHSCMP("B","MENTAL HEALTH/SOCIAL SERVICES",0))

 I DA S DIE="^APCHSCMP(",DR=".01///BEHAVIORAL HEALTH" D ^DIE K DIE,DA,DR

 Q

POST ;EP

 NEW X

 S X=$$ADD^XPDMENU("APCHSBLD","APCHSTED FM","FMMT")

 I 'X W "Attempt to add modify health summary option option failed." H 3

 S X=$$ADD^XPDMENU("APCHSMAINT","APCHSTED FM","FMMT")

 I 'X W "Attempt to add modify health summary option option failed." H 3

 I '$O(^APCHSCMP("B","MEDS - CHRONIC & ACUTE W/ ISSU",0)) D

 .D ^XBFMK S DIC="^APCHSCMP(",X="MEDS - CHRONIC & ACUTE W/ ISSUE HISTORY",DIC("DR")="2////Y",DIC(0)="L" K DD,DO,D0 D FILE^DICN

 .I Y=-1 W !!,"adding health summary component MEDS - CHRONIC & ACUTE W/ ISSUE HISTORY failed." D ^XBFMK Q

 .S $P(^APCHSCMP(+Y,0),U,2)="MEDSNDUP;APCHS78"

 I '$O(^APCHSCMP("B","MEDS - CHRONIC BY NAME",0)) D

 .D ^XBFMK S DIC="^APCHSCMP(",X="MEDS - CHRONIC BY NAME",DIC("DR")="2////Y;3////CHRONIC MEDICATIONS - SORTED BY DRUG NAME",DIC(0)="L" K DD,DO,D0 D FILE^DICN

 .I Y=-1 W !!,"adding health summary component MEDS - CHRONIC BY NAME failed." D ^XBFMK Q

 .S $P(^APCHSCMP(+Y,0),U,2)="MEDSCHRN;APCHS77"

 I '$O(^APCHSCMP("B","MEDS - CURRENT BY NAME",0)) D

 .D ^XBFMK S DIC="^APCHSCMP(",X="MEDS - CURRENT BY NAME",DIC("DR")="2////Y;3////CURRENT MEDICATIONS - SORTED BY DRUG NAME",DIC(0)="L" K DD,DO,D0 D FILE^DICN

 .I Y=-1 W !!,"adding health summary component MEDS - CURRENT BY NAME failed." D ^XBFMK Q

 .S $P(^APCHSCMP(+Y,0),U,2)="MEDSCURR;APCHS77"

 S DIK="^APCHSCTL(" D IXALL^DIK

 S DIK="^APCHSURV(" D IXALL^DIK

DUPE ;

 K APCHY,APCHZ S APCHX=0,APCHC=0 F  S APCHX=$O(^APCHSCMP(APCHX)) Q:APCHX'=+APCHX  D

 .I $P(^APCHSCMP(APCHX,0),U)'="MEDS - CHRONIC EXCLUDING D/C'ED MEDS" Q

 .S APCHC=APCHC+1,APCHY(APCHC)=APCHX,APCHZ(APCHX)=""

 I APCHC>1 D

 .;loop through types and change to first one

 .S APCHUSE=APCHY(1)

 .K APCHZ(APCHY(1)),APCHY(1)

 .S APCHT=0 F  S APCHT=$O(^APCHSCTL(APCHT)) Q:APCHT'=+APCHT  D

 ..S APCH1=0 F  S APCH1=$O(^APCHSCTL(APCHT,1,APCH1)) Q:APCH1'=+APCH1  D

 ...S APCH2=$P(^APCHSCTL(APCHT,1,APCH1,0),U,2)

 ...Q:'$D(APCHZ(APCH2))

 ...S DIE="^APCHSCTL("_APCHT_",1,",DA=APCH1,DA(1)=APCHT,DR="1////"_APCHUSE D ^DIE

 .S DA=0 F  S DA=$O(APCHZ(DA)) Q:DA'=+DA  S DIK="^APCHSCMP(" D ^DIK

 K APCHY,APCHZ S APCHX=0,APCHC=0 F  S APCHX=$O(^APCHSCMP(APCHX)) Q:APCHX'=+APCHX  D

 .I $P(^APCHSCMP(APCHX,0),U)'="PATIENT ED - MOST RECENT BY TOPIC" Q

 .S APCHC=APCHC+1,APCHY(APCHC)=APCHX,APCHZ(APCHX)=""

 I APCHC>1 D

 .;loop through types and change to first one

 .S APCHUSE=APCHY(1)

 .K APCHZ(APCHY(1)),APCHY(1)

 .S APCHT=0 F  S APCHT=$O(^APCHSCTL(APCHT)) Q:APCHT'=+APCHT  D

 ..S APCH1=0 F  S APCH1=$O(^APCHSCTL(APCHT,1,APCH1)) Q:APCH1'=+APCH1  D

 ...S APCH2=$P(^APCHSCTL(APCHT,1,APCH1,0),U,2)

 ...Q:'$D(APCHZ(APCH2))

 ...S DIE="^APCHSCTL("_APCHT_",1,",DA=APCH1,DA(1)=APCHT,DR="1////"_APCHUSE D ^DIE

 .S DA=0 F  S DA=$O(APCHZ(DA)) Q:DA'=+DA  S DIK="^APCHSCMP(" D ^DIK

 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

 S DA=$O(^APCHSURV("B","IHD-Elevated LDL Prompt",0))

 I DA S DR=".03///I",DIE="^APCHSURV(" D ^DIE K DIE,DA,DR

 S DA=$O(^APCHSURV("B","IHD-LDL Screening",0))

 I DA S DR=".03///I",DIE="^APCHSURV(" D ^DIE K DIE,DA,DR

 S DA=$O(^APCHSURV("B","ADULT MMR 1-DOSE VERSION",0))

 I DA S DR=".03///I",DIE="^APCHSURV(" D ^DIE K DIE,DA,DR

 S DA=$O(^APCHSURV("B","ADULT MMR 2-DOSE VERSION",0))

 I DA S DR=".03///I",DIE="^APCHSURV(" D ^DIE K DIE,DA,DR

 S DA=$O(^APCHSURV("B","RUBELLA VACCINATION",0))

 I DA S DR=".03///I",DIE="^APCHSURV(" D ^DIE K DIE,DA,DR

BUL ;

 D ^APCHBU11

 Q

 ;

CAT ;

 ;;BREAST EXAM;;GENERAL

 ;;DIABETES SCREENING;;DIABETES

 ;;BLOOD PRESSURE;;GENERAL

 ;;PAP SMEAR;;GENERAL

 ;;RECTAL;;GENERAL

 ;;TONOMETRY;;GENERAL

 ;;URINALYSIS;;GENERAL

 ;;PELVIC EXAM;;GENERAL

 ;;VISUAL ACUITY EXAM;;GENERAL

 ;;HEARING TEST;;GENERAL

 ;;HCT/HGB;;GENERAL

 ;;ENDEMIC TB;;GENERAL

 ;;NON-ENDEMIC TB;;GENERAL

 ;;HEAD CIRCUMFERENCE;;GENERAL

 ;;HEIGHT;;GENERAL

 ;;WEIGHT;;GENERAL

 ;;IMMUNIZATIONS;;GENERAL

 ;;HEARING TEST ANNUAL;;GENERAL

 ;;MAMMOGRAM;;GENERAL

 ;;PNEUMOVAX;;GENERAL

 ;;DM FOOT EXAM;;

 ;;DM EYE EXAM;;

 ;;SCREEN FOR ALCOHOL USE;;GENERAL

 ;;SCREEN FOR TOBACCO USE;;GENERAL

 ;;DM CHOLESTEROL;;

 ;;DM CREATININE;;

 ;;DM TRIGLYCERIDE;;

 ;;DM DENTAL EXAM;;

 ;;PHYSICAL EXAM;;GENERAL

 ;;TD-ADULT;;GENERAL

 ;;INFLUENZA;;GENERAL

 ;;COLORECTAL CA SCRN-FOBT;;GENERAL

 ;;CHOLESTEROL;;GENERAL

 ;;DM URINE PROTEIN;;

 ;;COLORECTAL CA-SCOPE/XRAY;;GENERAL

 ;;ALASKA DOMESTIC VIOLENCE;;GENERAL

 ;;HEARING INQUIRY;;GENERAL

 ;;STRABISMUS/AMBLYOPIA SCREEN;;GENERAL

 ;;PPD - TUBERCULOSIS;;GENERAL

 ;;ANMC DEPRESSION SCREEN SCORE;;GENERAL

 ;;REHAB/FUNCTIONAL SCREEN;;GENERAL

 ;;ANMC COLORECTAL;;GENERAL

 ;;ASTHMA - ADD/INCREASE INHALED STERIODS;;ASTHMA

 ;;ASTHMA - PRIMARY CARE PROVIDER;;ASTHMA

 ;;ASTHMA - SEVERITY CLASSIFICATION;;ASTHMA

 ;;ASTHMA - MANAGEMENT PLAN;;ASTHMA

 ;;ASTHMA PATIENT-FLU SHOT;;ASTHMA

 ;;IHD-LDL Screening;;CARDIOVASCULAR DISEASE

 ;;IHD-Elevated LDL Prompt;;CARDIOVASCULAR DISEASE

 ;;ADULT MMR 1-DOSE VERSION;;GENERAL

 ;;ADULT MMR 2-DOSE VERSION;;GENERAL

 ;;RUBELLA VACCINATION;;GENERAL

 ;;

APCH2P11  ; IHS/TUCSON/LAB - PCC HEALTH SUMMARY POST INIT PATCH 11 ;  [ 04/14/04  3:14 PM ]

 +1       ;;2.0;IHS RPMS/PCC Health Summary;**11**;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       ;

 +8        QUIT 

PRE       ;EP

 +1        SET DA=$ORDER(^APCHSCMP("B","MENTAL HEALTH/SOCIAL SERVICES",0))

 +2        IF DA

               SET DIE="^APCHSCMP("

               SET DR=".01///BEHAVIORAL HEALTH"

               DO ^DIE

               KILL DIE,DA,DR

 +3        QUIT 

POST      ;EP

 +1        NEW X

 +2        SET X=$$ADD^XPDMENU("APCHSBLD","APCHSTED FM","FMMT")

 +3        IF 'X

               WRITE "Attempt to add modify health summary option option failed."

               HANG 3

 +4        SET X=$$ADD^XPDMENU("APCHSMAINT","APCHSTED FM","FMMT")

 +5        IF 'X

               WRITE "Attempt to add modify health summary option option failed."

               HANG 3

 +6        IF '$ORDER(^APCHSCMP("B","MEDS - CHRONIC & ACUTE W/ ISSU",0))

               Begin DoDot:1

 +7                DO ^XBFMK

                   SET DIC="^APCHSCMP("

                   SET X="MEDS - CHRONIC & ACUTE W/ ISSUE HISTORY"

                   SET DIC("DR")="2////Y"

                   SET DIC(0)="L"

                   KILL DD,DO,D0

                   DO FILE^DICN

 +8                IF Y=-1

                       WRITE !!,"adding health summary component MEDS - CHRONIC & ACUTE W/ ISSUE HISTORY failed."

                       DO ^XBFMK

                       QUIT 

 +9                SET $PIECE(^APCHSCMP(+Y,0),U,2)="MEDSNDUP;APCHS78"

               End DoDot:1

 +10       IF '$ORDER(^APCHSCMP("B","MEDS - CHRONIC BY NAME",0))

               Begin DoDot:1

 +11               DO ^XBFMK

                   SET DIC="^APCHSCMP("

                   SET X="MEDS - CHRONIC BY NAME"

                   SET DIC("DR")="2////Y;3////CHRONIC MEDICATIONS - SORTED BY DRUG NAME"

                   SET DIC(0)="L"

                   KILL DD,DO,D0

                   DO FILE^DICN

 +12               IF Y=-1

                       WRITE !!,"adding health summary component MEDS - CHRONIC BY NAME failed."

                       DO ^XBFMK

                       QUIT 

 +13               SET $PIECE(^APCHSCMP(+Y,0),U,2)="MEDSCHRN;APCHS77"

               End DoDot:1

 +14       IF '$ORDER(^APCHSCMP("B","MEDS - CURRENT BY NAME",0))

               Begin DoDot:1

 +15               DO ^XBFMK

                   SET DIC="^APCHSCMP("

                   SET X="MEDS - CURRENT BY NAME"

                   SET DIC("DR")="2////Y;3////CURRENT MEDICATIONS - SORTED BY DRUG NAME"

                   SET DIC(0)="L"

                   KILL DD,DO,D0

                   DO FILE^DICN

 +16               IF Y=-1

                       WRITE !!,"adding health summary component MEDS - CURRENT BY NAME failed."

                       DO ^XBFMK

                       QUIT 

 +17               SET $PIECE(^APCHSCMP(+Y,0),U,2)="MEDSCURR;APCHS77"

               End DoDot:1

 +18       SET DIK="^APCHSCTL("

           DO IXALL^DIK

 +19       SET DIK="^APCHSURV("

           DO IXALL^DIK

DUPE      ;

 +1        KILL APCHY,APCHZ

           SET APCHX=0

           SET APCHC=0

           FOR 

               SET APCHX=$ORDER(^APCHSCMP(APCHX))

               IF APCHX'=+APCHX

                   QUIT 

               Begin DoDot:1

 +2                IF $PIECE(^APCHSCMP(APCHX,0),U)'="MEDS - CHRONIC EXCLUDING D/C'ED MEDS"

                       QUIT 

 +3                SET APCHC=APCHC+1

                   SET APCHY(APCHC)=APCHX

                   SET APCHZ(APCHX)=""

               End DoDot:1

 +4        IF APCHC>1

               Begin DoDot:1

 +5       ;loop through types and change to first one

 +6                SET APCHUSE=APCHY(1)

 +7                KILL APCHZ(APCHY(1)),APCHY(1)

 +8                SET APCHT=0

                   FOR 

                       SET APCHT=$ORDER(^APCHSCTL(APCHT))

                       IF APCHT'=+APCHT

                           QUIT 

                       Begin DoDot:2

 +9                        SET APCH1=0

                           FOR 

                               SET APCH1=$ORDER(^APCHSCTL(APCHT,1,APCH1))

                               IF APCH1'=+APCH1

                                   QUIT 

                               Begin DoDot:3

 +10                               SET APCH2=$PIECE(^APCHSCTL(APCHT,1,APCH1,0),U,2)

 +11                               IF '$DATA(APCHZ(APCH2))

                                       QUIT 

 +12                               SET DIE="^APCHSCTL("_APCHT_",1,"

                                   SET DA=APCH1

                                   SET DA(1)=APCHT

                                   SET DR="1////"_APCHUSE

                                   DO ^DIE

                               End DoDot:3

                       End DoDot:2

 +13               SET DA=0

                   FOR 

                       SET DA=$ORDER(APCHZ(DA))

                       IF DA'=+DA

                           QUIT 

                       SET DIK="^APCHSCMP("

                       DO ^DIK

               End DoDot:1

 +14       KILL APCHY,APCHZ

           SET APCHX=0

           SET APCHC=0

           FOR 

               SET APCHX=$ORDER(^APCHSCMP(APCHX))

               IF APCHX'=+APCHX

                   QUIT 

               Begin DoDot:1

 +15               IF $PIECE(^APCHSCMP(APCHX,0),U)'="PATIENT ED - MOST RECENT BY TOPIC"

                       QUIT 

 +16               SET APCHC=APCHC+1

                   SET APCHY(APCHC)=APCHX

                   SET APCHZ(APCHX)=""

               End DoDot:1

 +17       IF APCHC>1

               Begin DoDot:1

 +18      ;loop through types and change to first one

 +19               SET APCHUSE=APCHY(1)

 +20               KILL APCHZ(APCHY(1)),APCHY(1)

 +21               SET APCHT=0

                   FOR 

                       SET APCHT=$ORDER(^APCHSCTL(APCHT))

                       IF APCHT'=+APCHT

                           QUIT 

                       Begin DoDot:2

 +22                       SET APCH1=0

                           FOR 

                               SET APCH1=$ORDER(^APCHSCTL(APCHT,1,APCH1))

                               IF APCH1'=+APCH1

                                   QUIT 

                               Begin DoDot:3

 +23                               SET APCH2=$PIECE(^APCHSCTL(APCHT,1,APCH1,0),U,2)

 +24                               IF '$DATA(APCHZ(APCH2))

                                       QUIT 

 +25                               SET DIE="^APCHSCTL("_APCHT_",1,"

                                   SET DA=APCH1

                                   SET DA(1)=APCHT

                                   SET DR="1////"_APCHUSE

                                   DO ^DIE

                               End DoDot:3

                       End DoDot:2

 +26               SET DA=0

                   FOR 

                       SET DA=$ORDER(APCHZ(DA))

                       IF DA'=+DA

                           QUIT 

                       SET DIK="^APCHSCMP("

                       DO ^DIK

               End DoDot:1

 +27       SET APCHST="CAT"

           FOR APCHSX=1:1:999

               SET APCH1=$PIECE($TEXT(@APCHST+APCHSX),";;",2,99)

               IF APCH1=""

                   QUIT 

               Begin DoDot:1

 +28               KILL DIC

                   SET X=$PIECE(APCH1,";;",1)

                   SET DIC="^APCHSURV("

                   SET DIC(0)="M"

                   DO ^DIC

                   KILL DIC

 +29               IF Y=-1

                       QUIT 

 +30               SET DA=+Y

                   SET DR=".05///"_$PIECE(APCH1,";;",2)

                   SET DIE="^APCHSURV("

                   DO ^DIE

                   KILL DIE,DA,DR

 +31               IF $DATA(Y)

                       WRITE !,"category not updated. ",X

 +32               QUIT 

               End DoDot:1

 +33       SET DA=$ORDER(^APCHSURV("B","IHD-Elevated LDL Prompt",0))

 +34       IF DA

               SET DR=".03///I"

               SET DIE="^APCHSURV("

               DO ^DIE

               KILL DIE,DA,DR

 +35       SET DA=$ORDER(^APCHSURV("B","IHD-LDL Screening",0))

 +36       IF DA

               SET DR=".03///I"

               SET DIE="^APCHSURV("

               DO ^DIE

               KILL DIE,DA,DR

 +37       SET DA=$ORDER(^APCHSURV("B","ADULT MMR 1-DOSE VERSION",0))

 +38       IF DA

               SET DR=".03///I"

               SET DIE="^APCHSURV("

               DO ^DIE

               KILL DIE,DA,DR

 +39       SET DA=$ORDER(^APCHSURV("B","ADULT MMR 2-DOSE VERSION",0))

 +40       IF DA

               SET DR=".03///I"

               SET DIE="^APCHSURV("

               DO ^DIE

               KILL DIE,DA,DR

 +41       SET DA=$ORDER(^APCHSURV("B","RUBELLA VACCINATION",0))

 +42       IF DA

               SET DR=".03///I"

               SET DIE="^APCHSURV("

               DO ^DIE

               KILL DIE,DA,DR

BUL       ;

 +1        DO ^APCHBU11

 +2        QUIT 

 +3       ;

CAT       ;

 +1       ;;BREAST EXAM;;GENERAL

 +2       ;;DIABETES SCREENING;;DIABETES

 +3       ;;BLOOD PRESSURE;;GENERAL

 +4       ;;PAP SMEAR;;GENERAL

 +5       ;;RECTAL;;GENERAL

 +6       ;;TONOMETRY;;GENERAL

 +7       ;;URINALYSIS;;GENERAL

 +8       ;;PELVIC EXAM;;GENERAL

 +9       ;;VISUAL ACUITY EXAM;;GENERAL

 +10      ;;HEARING TEST;;GENERAL

 +11      ;;HCT/HGB;;GENERAL

 +12      ;;ENDEMIC TB;;GENERAL

 +13      ;;NON-ENDEMIC TB;;GENERAL

 +14      ;;HEAD CIRCUMFERENCE;;GENERAL

 +15      ;;HEIGHT;;GENERAL

 +16      ;;WEIGHT;;GENERAL

 +17      ;;IMMUNIZATIONS;;GENERAL

 +18      ;;HEARING TEST ANNUAL;;GENERAL

 +19      ;;MAMMOGRAM;;GENERAL

 +20      ;;PNEUMOVAX;;GENERAL

 +21      ;;DM FOOT EXAM;;

 +22      ;;DM EYE EXAM;;

 +23      ;;SCREEN FOR ALCOHOL USE;;GENERAL

 +24      ;;SCREEN FOR TOBACCO USE;;GENERAL

 +25      ;;DM CHOLESTEROL;;

 +26      ;;DM CREATININE;;

 +27      ;;DM TRIGLYCERIDE;;

 +28      ;;DM DENTAL EXAM;;

 +29      ;;PHYSICAL EXAM;;GENERAL

 +30      ;;TD-ADULT;;GENERAL

 +31      ;;INFLUENZA;;GENERAL

 +32      ;;COLORECTAL CA SCRN-FOBT;;GENERAL

 +33      ;;CHOLESTEROL;;GENERAL

 +34      ;;DM URINE PROTEIN;;

 +35      ;;COLORECTAL CA-SCOPE/XRAY;;GENERAL

 +36      ;;ALASKA DOMESTIC VIOLENCE;;GENERAL

 +37      ;;HEARING INQUIRY;;GENERAL

 +38      ;;STRABISMUS/AMBLYOPIA SCREEN;;GENERAL

 +39      ;;PPD - TUBERCULOSIS;;GENERAL

 +40      ;;ANMC DEPRESSION SCREEN SCORE;;GENERAL

 +41      ;;REHAB/FUNCTIONAL SCREEN;;GENERAL

 +42      ;;ANMC COLORECTAL;;GENERAL

 +43      ;;ASTHMA - ADD/INCREASE INHALED STERIODS;;ASTHMA

 +44      ;;ASTHMA - PRIMARY CARE PROVIDER;;ASTHMA

 +45      ;;ASTHMA - SEVERITY CLASSIFICATION;;ASTHMA

 +46      ;;ASTHMA - MANAGEMENT PLAN;;ASTHMA

 +47      ;;ASTHMA PATIENT-FLU SHOT;;ASTHMA

 +48      ;;IHD-LDL Screening;;CARDIOVASCULAR DISEASE

 +49      ;;IHD-Elevated LDL Prompt;;CARDIOVASCULAR DISEASE

 +50      ;;ADULT MMR 1-DOSE VERSION;;GENERAL

 +51      ;;ADULT MMR 2-DOSE VERSION;;GENERAL

 +52      ;;RUBELLA VACCINATION;;GENERAL

 +53      ;;