APCH2P15 ; IHS/TUCSON/LAB - PCC HEALTH SUMMARY POST INIT PATCH 12 ; [ 09/07/04 10:26 AM ]
;;2.0;IHS RPMS/PCC Health Summary;**14**;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
;
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
S DA=$O(^APCHSCMP("B","SCHEDULED ENCOUNTERS",0))
I DA S DIE="^APCHSCMP(",DR=".01///SCHEDULED ENCOUNTERS (W/CHART REQ&W/INS);3///SCHEDULED ENCOUNTERS (INCLUDES CHART REQ AND WALK INS)" D ^DIE K DIE,DA,DR
;SAVE OFF STATUS FOR EACH REMINDER
;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
NEW X
S DA=$O(^DIC(19,"B","APCH PATIENT HEALTH SUMMARY",0))
I DA S DIK="^DIC(19," D ^DIK
K DIK,DA
S X=$$DELETE^XPDMENU("APCHMENU","APCHPSUM")
S X=$$DELETE^XPDMENU("APCHSMAINT","APCHPSUM")
S DA=$O(^DIC(19,"B","APCHPSUM",0)) I DA S DIK="^DIC(19," D ^DIK
K DA,DIK
S X=$$ADD^XPDMENU("APCHMENU","APCHSPMH","PWH")
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
S X=$$ADD^XPDMENU("APCHSBLD","APCH SITE PARAMETER SETUP","HSSP")
I 'X W "Attempt to add health summary site parameter option failed." H 3
S X=$$ADD^XPDMENU("APCHSMAINT","APCH SITE PARAMETER SETUP","HSSP")
I 'X W "Attempt to add health summary site parameter option failed." H 3
;I 'X W "Attempt to add PATIENT health summary 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"
I '$O(^APCHSCMP("B","RADIOLOGY EXAMS",0)) D
.D ^XBFMK S DIC="^APCHSCMP(",X="RADIOLOGY EXAMS",DIC("DR")="2////Y",DIC(0)="L" K DD,DO,D0 D FILE^DICN
.I Y=-1 W !!,"adding health summary component RADIOLOGY failed." D ^XBFMK Q
.S $P(^APCHSCMP(+Y,0),U,2)="RAD;APCHS3C"
I '$O(^APCHSCMP("B","EDUCATIONAL ASSESSMENT",0)) D
.D ^XBFMK S DIC="^APCHSCMP(",X="EDUCATIONAL ASSESSMENT",DIC("DR")="2////N",DIC(0)="L" K DD,DO,D0 D FILE^DICN
.I Y=-1 W !!,"adding health summary component EDUCATIONAL ASSESSMENT failed." D ^XBFMK Q
.S $P(^APCHSCMP(+Y,0),U,2)="EDUCASSE;APCHS4A"
I '$O(^APCHSCMP("B","INFANT FEEDING CHOICE PANEL",0)) D
.D ^XBFMK S DIC="^APCHSCMP(",X="INFANT FEEDING CHOICE PANEL",DIC(0)="L" K DD,DO,D0 D FILE^DICN
.I Y=-1 W !!,"adding health summary component INFANT FEEDING CHOICE PANEL failed." D ^XBFMK Q
.S $P(^APCHSCMP(+Y,0),U,2)="BIRTHM;APCHS8"
I '$O(^APCHSCMP("B","SCHEDULED ENCS (W/O CHART REQ ",0)) D
.D ^XBFMK S DIC="^APCHSCMP(",X="SCHEDULED ENCS (W/O CHART REQ & W/INS)",DIC("DR")="2////Y",DIC(0)="L" K DD,DO,D0 D FILE^DICN
.I Y=-1 W !!,"adding health summary component INFANT FEEDING CHOICE PANEL failed." D ^XBFMK Q
.S $P(^APCHSCMP(+Y,0),U,2)="SCHENC;APCHS2J"
.S $P(^APCHSCMP(+Y,0),U,4)="SCHEDULED ENCOUNTERS (EXCLUDES CHART REQ AND WALK INS)"
I '$O(^APCHSCMP("B","WELL CHILD EXAM",0)) D
.D ^XBFMK S DIC="^APCHSCMP(",X="WELL CHILD EXAM",DIC("DR")="2////N",DIC(0)="L" K DD,DO,D0 D FILE^DICN
.I Y=-1 W !!,"adding health summary component WELL CHILD EXAM failed." D ^XBFMK Q
.S $P(^APCHSCMP(+Y,0),U,2)="WCE;APCHS6B"
S DIK="^APCHSCTL(" D IXALL^DIK
S DIK="^APCHSURV(" D IXALL^DIK
D ^APCHTX
S DA=$O(^ATXAX("B","APCH GLUCOSE SCREENING LOINC",0))
I DA S $P(^ATXAX(DA,0),U,4)="n",$P(^ATXAX(DA,0),U,22)=1
S DA=$O(^ATXAX("B","APCH HCT/HGB LOINC CODES",0))
I DA S $P(^ATXAX(DA,0),U,4)="n",$P(^ATXAX(DA,0),U,22)=1
S DA=$O(^ATXAX("B","SURVEILLANCE PNEUMOCOCCAL RISK",0))
I DA S $P(^ATXAX(DA,0),U,4)="n",$P(^ATXAX(DA,0),U,22)=1
S DA=$O(^ATXAX("B","APCH PNEUMOVAX REVAX",0))
I DA S $P(^ATXAX(DA,0),U,4)="n",$P(^ATXAX(DA,0),U,22)=1
S DA=$O(^ATXAX("B","APCH ISCHEMIC HEART DISEASE",0))
I DA S $P(^ATXAX(DA,0),U,4)="n",$P(^ATXAX(DA,0),U,22)=1
S DA=$O(^ATXAX("B","DM AUDIT PRE-DIABETES DXS",0))
I DA S $P(^ATXAX(DA,0),U,4)="n",$P(^ATXAX(DA,0),U,22)=1
S DA=$O(^ATXAX("B","DM AUDIT ESTIMATED GFR LOINC",0))
I DA S $P(^ATXAX(DA,0),U,4)="n",$P(^ATXAX(DA,0),U,22)=1
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
;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
;I '$$INSTALLD("APCH*2.00*11") D
;.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 SETTAXL
D CLNTAX
;D SETPROT ;NOT YET
D ^APCHBU15
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
SETPROT ;
S APCHE=$O(^ORD(101,"B","BSDAM APPOINTMENT EVENTS",0)) Q:'APCHE
S APCHITEM="APCH CHECK-IN PRINT PAT HS"
I $D(^ORD(101,"B",APCHITEM)) D ;if protocol exists
. S APCHIEN=$O(^ORD(101,"B",APCHITEM,0)) Q:'APCHIEN
. Q:$D(^ORD(101,APCHE,10,"B",APCHIEN)) ;already added to event driver
. ;
. ; go ahead and add it
. S DIC="^ORD(101,"_APCHE_",10,",DIC(0)="L",DLAYGO=101.01
. S DA(1)=APCHE,DIC("P")="101.01PA",X=APCHIEN
. S DIC("DR")="3///31"
. K DD,DO D FILE^DICN
. Q
Q
LAB1 ;
S APCHDA=$O(^ATXLAB("B",APCHX,0))
Q:APCHDA ;taxonomy already exisits
W !,"Creating ",APCHX," Taxonomy..."
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
SETTAXL ;
Q:'$D(^DD(9002228,4101,0)) ;taxonomy patch not yet installed
S APCHTEXT="LABTAX" F BGPX=1:1 S APCHDATA=$P($T(@APCHTEXT+APCHX),";;",2) Q:APCHDATA="" D
.S APCHDA=$O(^ATXLAB("B",$P(APCHDATA,"|"),0))
.Q:APCHDA=""
.S $P(^ATXLAB(APCHDA,0),U,4)="n" W !,$P(APCHDATA,"|") ;SET NO DELETE
.S $P(^ATXLAB(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="^ATXLAB("_APCHDA_",41,",DIC(0)="L",DIC("P")=$P(^DD(9002228,4101,0),U,2),DA(1)=APCHDA
..D ^DIC
..I Y=-1 W !,"updating package multiple for ",APCHPP," entry ",$P(^ATXLAB(APCHDA,0),U)," failed"
..K DIC,DA,Y,X
.Q
Q
LABTAX ;
;;BGP GPRA ESTIMATED GFR TAX|0|BGP*APCH
;;APCH FECAL OCCULT BLOOD
;;APCH HCT/HGB TESTS
;;DM AUDIT 2 HR GTT TAX
;;
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
CLNTAX ;
S ATXFLG=1
W !,"Creating Clinic exclusions taxonomy..."
S BGPDA=0 S BGPDA=$O(^ATXAX("B","APCH CLINIC STOP FOR PT HS",BGPDA))
I BGPDA Q ;S DA=BGPDA S DIK="^ATXAX(" D ^DIK K DA,DIK
S X="APCH CLINIC STOP FOR PT HS",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 CLINIC STOP FOR PT HS TAX" Q
S BGPTX=+Y,$P(^ATXAX(BGPTX,0),U,2)="APCH CLINIC STOP FOR PT HS",$P(^(0),U,5)=DUZ,$P(^(0),U,8)=0,$P(^(0),U,9)=DT,$P(^(0),U,12)=172,$P(^(0),U,13)=0,$P(^(0),U,15)=40.7,^ATXAX(BGPTX,21,0)="^9002226.02101A^0^0"
D ^XBFMK K DIADD,DLAYGO S BGPTEXT="CLINICS" F BGPX=1:1:17 S X=$P($T(@BGPTEXT+BGPX),";;",2),Y=$O(^DIC(40.7,"C",X,0)) W !,Y," ",X I Y D
.S ^ATXAX(BGPTX,21,BGPX,0)=+Y,$P(^ATXAX(BGPTX,21,0),U,3)=BGPX,$P(^(0),U,4)=BGPX,^ATXAX(BGPTX,21,"AA",+Y,+Y)=""
.Q
S DA=BGPTX,DIK="^ATXAX(" D IX1^DIK
Q
;
CLINICS ;;
;;77
;;52
;;56
;;60
;;68
;;53
;;09
;;22
;;90
;;51
;;99
;;41
;;42
;;A9
;;39
;;45
;;54
;;
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
;;
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
;;DM AUDIT ESTIMATED GFR LOINC|1|APCH*APCL
;;
APCH2P15 ; IHS/TUCSON/LAB - PCC HEALTH SUMMARY POST INIT PATCH 12 ; [ 09/07/04 10:26 AM ]
+1 ;;2.0;IHS RPMS/PCC Health Summary;**14**;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 ;
+9 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 SET DA=$ORDER(^APCHSCMP("B","SCHEDULED ENCOUNTERS",0))
+4 IF DA
SET DIE="^APCHSCMP("
SET DR=".01///SCHEDULED ENCOUNTERS (W/CHART REQ&W/INS);3///SCHEDULED ENCOUNTERS (INCLUDES CHART REQ AND WALK INS)"
DO ^DIE
KILL DIE,DA,DR
+5 ;SAVE OFF STATUS FOR EACH REMINDER
+6 ;K ^APCHTMP("HMR STATUS")
+7 ;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)
+8 QUIT
POST ;EP
+1 NEW X
+2 SET DA=$ORDER(^DIC(19,"B","APCH PATIENT HEALTH SUMMARY",0))
+3 IF DA
SET DIK="^DIC(19,"
DO ^DIK
+4 KILL DIK,DA
+5 SET X=$$DELETE^XPDMENU("APCHMENU","APCHPSUM")
+6 SET X=$$DELETE^XPDMENU("APCHSMAINT","APCHPSUM")
+7 SET DA=$ORDER(^DIC(19,"B","APCHPSUM",0))
IF DA
SET DIK="^DIC(19,"
DO ^DIK
+8 KILL DA,DIK
+9 SET X=$$ADD^XPDMENU("APCHMENU","APCHSPMH","PWH")
+10 SET X=$$ADD^XPDMENU("APCHSBLD","APCHSTED FM","FMMT")
+11 IF 'X
WRITE "Attempt to add modify health summary option option failed."
HANG 3
+12 SET X=$$ADD^XPDMENU("APCHSMAINT","APCHSTED FM","FMMT")
+13 IF 'X
WRITE "Attempt to add modify health summary option option failed."
HANG 3
+14 SET X=$$ADD^XPDMENU("APCHSBLD","APCH SITE PARAMETER SETUP","HSSP")
+15 IF 'X
WRITE "Attempt to add health summary site parameter option failed."
HANG 3
+16 SET X=$$ADD^XPDMENU("APCHSMAINT","APCH SITE PARAMETER SETUP","HSSP")
+17 IF 'X
WRITE "Attempt to add health summary site parameter option failed."
HANG 3
+18 ;I 'X W "Attempt to add PATIENT health summary option failed." H 3
+19 IF '$ORDER(^APCHSCMP("B","MEDS - CHRONIC & ACUTE W/ ISSU",0))
Begin DoDot:1
+20 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
+21 IF Y=-1
WRITE !!,"adding health summary component MEDS - CHRONIC & ACUTE W/ ISSUE HISTORY failed."
DO ^XBFMK
QUIT
+22 SET $PIECE(^APCHSCMP(+Y,0),U,2)="MEDSNDUP;APCHS78"
End DoDot:1
+23 IF '$ORDER(^APCHSCMP("B","MEDS - CHRONIC BY NAME",0))
Begin DoDot:1
+24 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
+25 IF Y=-1
WRITE !!,"adding health summary component MEDS - CHRONIC BY NAME failed."
DO ^XBFMK
QUIT
+26 SET $PIECE(^APCHSCMP(+Y,0),U,2)="MEDSCHRN;APCHS77"
End DoDot:1
+27 IF '$ORDER(^APCHSCMP("B","MEDS - CURRENT BY NAME",0))
Begin DoDot:1
+28 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
+29 IF Y=-1
WRITE !!,"adding health summary component MEDS - CURRENT BY NAME failed."
DO ^XBFMK
QUIT
+30 SET $PIECE(^APCHSCMP(+Y,0),U,2)="MEDSCURR;APCHS77"
End DoDot:1
+31 IF '$ORDER(^APCHSCMP("B","RADIOLOGY EXAMS",0))
Begin DoDot:1
+32 DO ^XBFMK
SET DIC="^APCHSCMP("
SET X="RADIOLOGY EXAMS"
SET DIC("DR")="2////Y"
SET DIC(0)="L"
KILL DD,DO,D0
DO FILE^DICN
+33 IF Y=-1
WRITE !!,"adding health summary component RADIOLOGY failed."
DO ^XBFMK
QUIT
+34 SET $PIECE(^APCHSCMP(+Y,0),U,2)="RAD;APCHS3C"
End DoDot:1
+35 IF '$ORDER(^APCHSCMP("B","EDUCATIONAL ASSESSMENT",0))
Begin DoDot:1
+36 DO ^XBFMK
SET DIC="^APCHSCMP("
SET X="EDUCATIONAL ASSESSMENT"
SET DIC("DR")="2////N"
SET DIC(0)="L"
KILL DD,DO,D0
DO FILE^DICN
+37 IF Y=-1
WRITE !!,"adding health summary component EDUCATIONAL ASSESSMENT failed."
DO ^XBFMK
QUIT
+38 SET $PIECE(^APCHSCMP(+Y,0),U,2)="EDUCASSE;APCHS4A"
End DoDot:1
+39 IF '$ORDER(^APCHSCMP("B","INFANT FEEDING CHOICE PANEL",0))
Begin DoDot:1
+40 DO ^XBFMK
SET DIC="^APCHSCMP("
SET X="INFANT FEEDING CHOICE PANEL"
SET DIC(0)="L"
KILL DD,DO,D0
DO FILE^DICN
+41 IF Y=-1
WRITE !!,"adding health summary component INFANT FEEDING CHOICE PANEL failed."
DO ^XBFMK
QUIT
+42 SET $PIECE(^APCHSCMP(+Y,0),U,2)="BIRTHM;APCHS8"
End DoDot:1
+43 IF '$ORDER(^APCHSCMP("B","SCHEDULED ENCS (W/O CHART REQ ",0))
Begin DoDot:1
+44 DO ^XBFMK
SET DIC="^APCHSCMP("
SET X="SCHEDULED ENCS (W/O CHART REQ & W/INS)"
SET DIC("DR")="2////Y"
SET DIC(0)="L"
KILL DD,DO,D0
DO FILE^DICN
+45 IF Y=-1
WRITE !!,"adding health summary component INFANT FEEDING CHOICE PANEL failed."
DO ^XBFMK
QUIT
+46 SET $PIECE(^APCHSCMP(+Y,0),U,2)="SCHENC;APCHS2J"
+47 SET $PIECE(^APCHSCMP(+Y,0),U,4)="SCHEDULED ENCOUNTERS (EXCLUDES CHART REQ AND WALK INS)"
End DoDot:1
+48 IF '$ORDER(^APCHSCMP("B","WELL CHILD EXAM",0))
Begin DoDot:1
+49 DO ^XBFMK
SET DIC="^APCHSCMP("
SET X="WELL CHILD EXAM"
SET DIC("DR")="2////N"
SET DIC(0)="L"
KILL DD,DO,D0
DO FILE^DICN
+50 IF Y=-1
WRITE !!,"adding health summary component WELL CHILD EXAM failed."
DO ^XBFMK
QUIT
+51 SET $PIECE(^APCHSCMP(+Y,0),U,2)="WCE;APCHS6B"
End DoDot:1
+52 SET DIK="^APCHSCTL("
DO IXALL^DIK
+53 SET DIK="^APCHSURV("
DO IXALL^DIK
+54 DO ^APCHTX
+55 SET DA=$ORDER(^ATXAX("B","APCH GLUCOSE SCREENING LOINC",0))
+56 IF DA
SET $PIECE(^ATXAX(DA,0),U,4)="n"
SET $PIECE(^ATXAX(DA,0),U,22)=1
+57 SET DA=$ORDER(^ATXAX("B","APCH HCT/HGB LOINC CODES",0))
+58 IF DA
SET $PIECE(^ATXAX(DA,0),U,4)="n"
SET $PIECE(^ATXAX(DA,0),U,22)=1
+59 SET DA=$ORDER(^ATXAX("B","SURVEILLANCE PNEUMOCOCCAL RISK",0))
+60 IF DA
SET $PIECE(^ATXAX(DA,0),U,4)="n"
SET $PIECE(^ATXAX(DA,0),U,22)=1
+61 SET DA=$ORDER(^ATXAX("B","APCH PNEUMOVAX REVAX",0))
+62 IF DA
SET $PIECE(^ATXAX(DA,0),U,4)="n"
SET $PIECE(^ATXAX(DA,0),U,22)=1
+63 SET DA=$ORDER(^ATXAX("B","APCH ISCHEMIC HEART DISEASE",0))
+64 IF DA
SET $PIECE(^ATXAX(DA,0),U,4)="n"
SET $PIECE(^ATXAX(DA,0),U,22)=1
+65 SET DA=$ORDER(^ATXAX("B","DM AUDIT PRE-DIABETES DXS",0))
+66 IF DA
SET $PIECE(^ATXAX(DA,0),U,4)="n"
SET $PIECE(^ATXAX(DA,0),U,22)=1
+67 SET DA=$ORDER(^ATXAX("B","DM AUDIT ESTIMATED GFR LOINC",0))
+68 IF DA
SET $PIECE(^ATXAX(DA,0),U,4)="n"
SET $PIECE(^ATXAX(DA,0),U,22)=1
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 ;PUT STATUS BACK IN
+34 ;S APCHX=0 F S APCHX=$O(^APCHTMP("HMR STATUS",APCHX)) Q:APCHX'=+APCHX D
+35 ;.S X=$P(^APCHTMP("HMR STATUS",APCHX),U),APCHS=$P(^APCHTMP("HMR STATUS",APCHX),U,2),DIC="^APCHSURV(",DIC(0)="M" D ^DIC
+36 ;.I Y=-1 W !!,"could not update status on ",X," hmr" Q
+37 ;.S $P(^APCHSURV(+Y,0),U,3)=APCHS
+38 ;I '$$INSTALLD("APCH*2.00*11") D
+39 ;.S DA=$O(^APCHSURV("B","IHD-Elevated LDL Prompt",0))
+40 ;.I DA S DR=".03///I",DIE="^APCHSURV(" D ^DIE K DIE,DA,DR
+41 ;.S DA=$O(^APCHSURV("B","IHD-LDL Screening",0))
+42 ;.I DA S DR=".03///I",DIE="^APCHSURV(" D ^DIE K DIE,DA,DR
+43 ;.S DA=$O(^APCHSURV("B","ADULT MMR 1-DOSE VERSION",0))
+44 ;.I DA S DR=".03///I",DIE="^APCHSURV(" D ^DIE K DIE,DA,DR
+45 ;.S DA=$O(^APCHSURV("B","ADULT MMR 2-DOSE VERSION",0))
+46 ;.;I DA S DR=".03///I",DIE="^APCHSURV(" D ^DIE K DIE,DA,DR
+47 ;.S DA=$O(^APCHSURV("B","RUBELLA VACCINATION",0))
+48 ;.I DA S DR=".03///I",DIE="^APCHSURV(" D ^DIE K DIE,DA,DR
BUL ;
+1 DO SETTAXL
+2 DO CLNTAX
+3 ;D SETPROT ;NOT YET
+4 DO ^APCHBU15
+5 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
SETPROT ;
+1 SET APCHE=$ORDER(^ORD(101,"B","BSDAM APPOINTMENT EVENTS",0))
IF 'APCHE
QUIT
+2 SET APCHITEM="APCH CHECK-IN PRINT PAT HS"
+3 ;if protocol exists
IF $DATA(^ORD(101,"B",APCHITEM))
Begin DoDot:1
+4 SET APCHIEN=$ORDER(^ORD(101,"B",APCHITEM,0))
IF 'APCHIEN
QUIT
+5 ;already added to event driver
IF $DATA(^ORD(101,APCHE,10,"B",APCHIEN))
QUIT
+6 ;
+7 ; go ahead and add it
+8 SET DIC="^ORD(101,"_APCHE_",10,"
SET DIC(0)="L"
SET DLAYGO=101.01
+9 SET DA(1)=APCHE
SET DIC("P")="101.01PA"
SET X=APCHIEN
+10 SET DIC("DR")="3///31"
+11 KILL DD,DO
DO FILE^DICN
+12 QUIT
End DoDot:1
+13 QUIT
LAB1 ;
+1 SET APCHDA=$ORDER(^ATXLAB("B",APCHX,0))
+2 ;taxonomy already exisits
IF APCHDA
QUIT
+3 WRITE !,"Creating ",APCHX," Taxonomy..."
+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
SETTAXL ;
+1 ;taxonomy patch not yet installed
IF '$DATA(^DD(9002228,4101,0))
QUIT
+2 SET APCHTEXT="LABTAX"
FOR BGPX=1:1
SET APCHDATA=$PIECE($TEXT(@APCHTEXT+APCHX),";;",2)
IF APCHDATA=""
QUIT
Begin DoDot:1
+3 SET APCHDA=$ORDER(^ATXLAB("B",$PIECE(APCHDATA,"|"),0))
+4 IF APCHDA=""
QUIT
+5 ;SET NO DELETE
SET $PIECE(^ATXLAB(APCHDA,0),U,4)="n"
WRITE !,$PIECE(APCHDATA,"|")
+6 ;set read only
SET $PIECE(^ATXLAB(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="^ATXLAB("_APCHDA_",41,"
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(9002228,4101,0),U,2)
SET DA(1)=APCHDA
+14 DO ^DIC
+15 IF Y=-1
WRITE !,"updating package multiple for ",APCHPP," entry ",$PIECE(^ATXLAB(APCHDA,0),U)," failed"
+16 KILL DIC,DA,Y,X
End DoDot:2
+17 QUIT
End DoDot:1
+18 QUIT
LABTAX ;
+1 ;;BGP GPRA ESTIMATED GFR TAX|0|BGP*APCH
+2 ;;APCH FECAL OCCULT BLOOD
+3 ;;APCH HCT/HGB TESTS
+4 ;;DM AUDIT 2 HR GTT TAX
+5 ;;
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
CLNTAX ;
+1 SET ATXFLG=1
+2 WRITE !,"Creating Clinic exclusions taxonomy..."
+3 SET BGPDA=0
SET BGPDA=$ORDER(^ATXAX("B","APCH CLINIC STOP FOR PT HS",BGPDA))
+4 ;S DA=BGPDA S DIK="^ATXAX(" D ^DIK K DA,DIK
IF BGPDA
QUIT
+5 SET X="APCH CLINIC STOP FOR PT HS"
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 CLINIC STOP FOR PT HS TAX"
QUIT
+7 SET BGPTX=+Y
SET $PIECE(^ATXAX(BGPTX,0),U,2)="APCH CLINIC STOP FOR PT HS"
SET $PIECE(^(0),U,5)=DUZ
SET $PIECE(^(0),U,8)=0
SET $PIECE(^(0),U,9)=DT
SET $PIECE(^(0),U,12)=172
SET $PIECE(^(0),U,13)=0
SET $PIECE(^(0),U,15)=40.7
SET ^ATXAX(BGPTX,21,0)="^9002226.02101A^0^0"
+8 DO ^XBFMK
KILL DIADD,DLAYGO
SET BGPTEXT="CLINICS"
FOR BGPX=1:1:17
SET X=$PIECE($TEXT(@BGPTEXT+BGPX),";;",2)
SET Y=$ORDER(^DIC(40.7,"C",X,0))
WRITE !,Y," ",X
IF Y
Begin DoDot:1
+9 SET ^ATXAX(BGPTX,21,BGPX,0)=+Y
SET $PIECE(^ATXAX(BGPTX,21,0),U,3)=BGPX
SET $PIECE(^(0),U,4)=BGPX
SET ^ATXAX(BGPTX,21,"AA",+Y,+Y)=""
+10 QUIT
End DoDot:1
+11 SET DA=BGPTX
SET DIK="^ATXAX("
DO IX1^DIK
+12 QUIT
+13 ;
CLINICS ;;
+1 ;;77
+2 ;;52
+3 ;;56
+4 ;;60
+5 ;;68
+6 ;;53
+7 ;;09
+8 ;;22
+9 ;;90
+10 ;;51
+11 ;;99
+12 ;;41
+13 ;;42
+14 ;;A9
+15 ;;39
+16 ;;45
+17 ;;54
+18 ;;
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 ;;
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 ;;DM AUDIT ESTIMATED GFR LOINC|1|APCH*APCL
+8 ;;
