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
