APCH20P8.m

APCH20P8 ; IHS/TUCSON/LAB - PCC HEALTH SUMMARY POST INIT PATCH 8 ;  [ 08/31/02  4:43 PM ]

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

 S DA=$O(^APCHSCMP("B","ALLERGIES",0))

 I DA S DIE="^APCHSCMP(",DR=".01///ALLERGIES (FROM PROBLEM LIST)" D ^DIE K X,Y,DIE,DA,DR D ^XBFMK

 ;

 Q

POST ;

 D ^APCHBUL

 NEW X

 S X=$$ADD^XPDMENU("APCHSMAINT","APCH MENU HEALTH MAINTENANCE","HM",1.1)

 I 'X W "Attempt to add Health Maintenance Menu option failed." H 3

 ;rename hlth main reminders if exist

 F X=1:1:42 S Y=$T(@(X)) I $D(^APCHSURV(X,0)),$P(^APCHSURV(X,0),U)'=$P(Y,";;",2) S $P(^APCHSURV(X,0),U)=$P(Y,";;",2)

 K ^APCHSURV("B")

 S DIK="^APCHSURV(",DIK(1)=".01^B" D ENALL^DIK

 ;RENAME if needed

 ;status on domestic violence to delete

 S X=$O(^APCHSURV("B","ALASKA DOMESTIC VIOLENCE",0)) I X S $P(^APCHSURV(X,0),U,3)="D"

 D ^APCHTX

DMADA ;

 S ATXFLG=1

 W !,"Creating APCH ADA Codes Taxonomy..."

 S APCHDA=0 S APCHDA=$O(^ATXAX("B","APCH DM ADA EXAMS",APCHDA))

 I APCHDA G LAB

 S X="APCH DM ADA EXAMS",DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DIADD,DLAYGO,I

 I Y=-1 W !!,"ERROR IN CREATING APCH DM ADA EXAMS TAXONOMY" G LAB

 S APCHTX=+Y,$P(^ATXAX(APCHTX,0),U,2)="ADA CODES FOR DM EXAM",$P(^(0),U,5)=DUZ,$P(^(0),U,8)=0,$P(^(0),U,9)=DT,$P(^(0),U,12)=174,$P(^(0),U,13)=0,$P(^(0),U,15)=9999999.31,^ATXAX(APCHTX,21,0)="^9002226.02101A^0^0"

 S APCHTEXT="ADA" F APCHX=1:1:2 S X=$P($T(@APCHTEXT+APCHX),";;",2),DIC="^AUTTADA(",DIC(0)="M" D ^DIC K DIC,DA,DR,DIADD,DLAYGO,DQ,DI,D1,D0 I $P(Y,U)>0 D

 .S ^ATXAX(APCHTX,21,APCHX,0)=+Y,$P(^ATXAX(APCHTX,21,0),U,3)=APCHX,$P(^(0),U,4)=APCHX,^ATXAX(APCHTX,21,"AA",+Y,+Y)=""

 .Q

 S DA=APCHTX,DIK="^ATXAX(" D IX1^DIK

 K APCHTX,APCHDA,APCHTEXT,ATXFLG

 D ^XBFMK

LAB ;

 S APCHX="APCH FECAL OCCULT BLOOD" D LAB1

 S APCHX="APCH HCT/HGB TESTS" D LAB1

 Q

LAB1 ;

 W !,"Creating ",APCHX," Taxonomy..."

 S APCHDA=$O(^ATXLAB("B",APCHX,0))

 Q:APCHDA  ;taxonomy already exisits

 S X=APCHX,DIC="^ATXLAB(",DIC(0)="L",DIADD=1,DLAYGO=9002228 D ^DIC K DIC,DA,DIADD,DLAYGO,I

 I Y=-1 W !!,"ERROR IN CREATING ",APCHX," TAX" Q

 S APCHTX=+Y,$P(^ATXLAB(APCHTX,0),U,2)=APCHX,$P(^(0),U,5)=DUZ,$P(^(0),U,6)=DT,$P(^(0),U,8)="B",$P(^(0),U,9)=60,^ATXLAB(APCHTX,21,0)="^9002228.02101PA^0^0"

 S DA=APCHTX,DIK="^ATXAX(" D IX1^DIK

 Q

 ;

ADA ;

 ;;4110

 ;;0112

 ;;0120

 ;;0130

 ;;0114

 ;;0150

 ;

1 ;;BREAST EXAM;;

2 ;;DIABETES SCREENING;;

3 ;;BLOOD PRESSURE;;

4 ;;PAP SMEAR;;

5 ;;RECTAL;;

6 ;;TONOMETRY;;

7 ;;URINALYSIS;;

8 ;;PELVIC EXAM;;

9 ;;VISUAL ACUITY EXAM;;

10 ;;HEARING TEST;;

11 ;;HCT/HGB;;

12 ;;ENDEMIC TB;;

13 ;;NON-ENDEMIC TB;;

14 ;;HEAD CIRCUMFERENCE;;

15 ;;HEIGHT;;

16 ;;WEIGHT;;

17 ;;IMMUNIZATIONS;;

18 ;;HEARING TEST ANNUAL;;

19 ;;MAMMOGRAM;;

20 ;;PNEUMOVAX;;

21 ;;DM FOOT EXAM;;

22 ;;DM EYE EXAM;;

23 ;;SCREEN FOR ALCOHOL USE;;

24 ;;SCREEN FOR TOBACCO USE;;

25 ;;DM CHOLESTEROL;;

26 ;;DM CREATININE;;

27 ;;DM TRIGLYCERIDE;;

28 ;;DM DENTAL EXAM;;

29 ;;PHYSICAL EXAM;;

30 ;;TD-ADULT;;

32 ;;INFLUENZA;;

33 ;;COLORECTAL CA SCRN-FOBT;;

34 ;;CHOLESTEROL;;

35 ;;DM URINE PROTEIN;;

36 ;;COLORECTAL CA-SCOPE/XRAY;;

37 ;;ALASKA DOMESTIC VIOLENCE;;

38 ;;HEARING INQUIRY;;

39 ;;STRABISMUS/AMBLYOPIA SCREEN;;

40 ;;PPD - TUBERCULOSIS;;

41 ;;ANMC DEPRESSION SCREEN SCORE;;

42 ;;REHAB/FUNCTIONAL SCREEN

APCH20P8  ; IHS/TUCSON/LAB - PCC HEALTH SUMMARY POST INIT PATCH 8 ;  [ 08/31/02  4:43 PM ]

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

 +1        SET DA=$ORDER(^APCHSCMP("B","ALLERGIES",0))

 +2        IF DA

               SET DIE="^APCHSCMP("

               SET DR=".01///ALLERGIES (FROM PROBLEM LIST)"

               DO ^DIE

               KILL X,Y,DIE,DA,DR

               DO ^XBFMK

 +3       ;

 +4        QUIT 

POST      ;

 +1        DO ^APCHBUL

 +2        NEW X

 +3        SET X=$$ADD^XPDMENU("APCHSMAINT","APCH MENU HEALTH MAINTENANCE","HM",1.1)

 +4        IF 'X

               WRITE "Attempt to add Health Maintenance Menu option failed."

               HANG 3

 +5       ;rename hlth main reminders if exist

 +6        FOR X=1:1:42

               SET Y=$TEXT(@(X))

               IF $DATA(^APCHSURV(X,0))

                   IF $PIECE(^APCHSURV(X,0),U)'=$PIECE(Y,";;",2)

                       SET $PIECE(^APCHSURV(X,0),U)=$PIECE(Y,";;",2)

 +7        KILL ^APCHSURV("B")

 +8        SET DIK="^APCHSURV("

           SET DIK(1)=".01^B"

           DO ENALL^DIK

 +9       ;RENAME if needed

 +10      ;status on domestic violence to delete

 +11       SET X=$ORDER(^APCHSURV("B","ALASKA DOMESTIC VIOLENCE",0))

           IF X

               SET $PIECE(^APCHSURV(X,0),U,3)="D"

 +12       DO ^APCHTX

DMADA     ;

 +1        SET ATXFLG=1

 +2        WRITE !,"Creating APCH ADA Codes Taxonomy..."

 +3        SET APCHDA=0

           SET APCHDA=$ORDER(^ATXAX("B","APCH DM ADA EXAMS",APCHDA))

 +4        IF APCHDA

               GOTO LAB

 +5        SET X="APCH DM ADA EXAMS"

           SET DIC="^ATXAX("

           SET DIC(0)="L"

           SET DIADD=1

           SET DLAYGO=9002226

           DO ^DIC

           KILL DIC,DA,DIADD,DLAYGO,I

 +6        IF Y=-1

               WRITE !!,"ERROR IN CREATING APCH DM ADA EXAMS TAXONOMY"

               GOTO LAB

 +7        SET APCHTX=+Y

           SET $PIECE(^ATXAX(APCHTX,0),U,2)="ADA CODES FOR DM EXAM"

           SET $PIECE(^(0),U,5)=DUZ

           SET $PIECE(^(0),U,8)=0

           SET $PIECE(^(0),U,9)=DT

           SET $PIECE(^(0),U,12)=174

           SET $PIECE(^(0),U,13)=0

           SET $PIECE(^(0),U,15)=9999999.31

           SET ^ATXAX(APCHTX,21,0)="^9002226.02101A^0^0"

 +8        SET APCHTEXT="ADA"

           FOR APCHX=1:1:2

               SET X=$PIECE($TEXT(@APCHTEXT+APCHX),";;",2)

               SET DIC="^AUTTADA("

               SET DIC(0)="M"

               DO ^DIC

               KILL DIC,DA,DR,DIADD,DLAYGO,DQ,DI,D1,D0

               IF $PIECE(Y,U)>0

                   Begin DoDot:1

 +9                    SET ^ATXAX(APCHTX,21,APCHX,0)=+Y

                       SET $PIECE(^ATXAX(APCHTX,21,0),U,3)=APCHX

                       SET $PIECE(^(0),U,4)=APCHX

                       SET ^ATXAX(APCHTX,21,"AA",+Y,+Y)=""

 +10                   QUIT 

                   End DoDot:1

 +11       SET DA=APCHTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +12       KILL APCHTX,APCHDA,APCHTEXT,ATXFLG

 +13       DO ^XBFMK

LAB       ;

 +1        SET APCHX="APCH FECAL OCCULT BLOOD"

           DO LAB1

 +2        SET APCHX="APCH HCT/HGB TESTS"

           DO LAB1

 +3        QUIT 

LAB1      ;

 +1        WRITE !,"Creating ",APCHX," Taxonomy..."

 +2        SET APCHDA=$ORDER(^ATXLAB("B",APCHX,0))

 +3       ;taxonomy already exisits

           IF APCHDA

               QUIT 

 +4        SET X=APCHX

           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 ",APCHX," TAX"

               QUIT 

 +6        SET APCHTX=+Y

           SET $PIECE(^ATXLAB(APCHTX,0),U,2)=APCHX

           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(APCHTX,21,0)="^9002228.02101PA^0^0"

 +7        SET DA=APCHTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +8        QUIT 

 +9       ;

ADA       ;

 +1       ;;4110

 +2       ;;0112

 +3       ;;0120

 +4       ;;0130

 +5       ;;0114

 +6       ;;0150

 +7       ;

1         ;;BREAST EXAM;;

2         ;;DIABETES SCREENING;;

3         ;;BLOOD PRESSURE;;

4         ;;PAP SMEAR;;

5         ;;RECTAL;;

6         ;;TONOMETRY;;

7         ;;URINALYSIS;;

8         ;;PELVIC EXAM;;

9         ;;VISUAL ACUITY EXAM;;

10        ;;HEARING TEST;;

11        ;;HCT/HGB;;

12        ;;ENDEMIC TB;;

13        ;;NON-ENDEMIC TB;;

14        ;;HEAD CIRCUMFERENCE;;

15        ;;HEIGHT;;

16        ;;WEIGHT;;

17        ;;IMMUNIZATIONS;;

18        ;;HEARING TEST ANNUAL;;

19        ;;MAMMOGRAM;;

20        ;;PNEUMOVAX;;

21        ;;DM FOOT EXAM;;

22        ;;DM EYE EXAM;;

23        ;;SCREEN FOR ALCOHOL USE;;

24        ;;SCREEN FOR TOBACCO USE;;

25        ;;DM CHOLESTEROL;;

26        ;;DM CREATININE;;

27        ;;DM TRIGLYCERIDE;;

28        ;;DM DENTAL EXAM;;

29        ;;PHYSICAL EXAM;;

30        ;;TD-ADULT;;

32        ;;INFLUENZA;;

33        ;;COLORECTAL CA SCRN-FOBT;;

34        ;;CHOLESTEROL;;

35        ;;DM URINE PROTEIN;;

36        ;;COLORECTAL CA-SCOPE/XRAY;;

37        ;;ALASKA DOMESTIC VIOLENCE;;

38        ;;HEARING INQUIRY;;

39        ;;STRABISMUS/AMBLYOPIA SCREEN;;

40        ;;PPD - TUBERCULOSIS;;

41        ;;ANMC DEPRESSION SCREEN SCORE;;

42        ;;REHAB/FUNCTIONAL SCREEN