APCH2P13 ; IHS/TUCSON/LAB - PCC HEALTH SUMMARY POST INIT PATCH 12 ; [ 09/07/04 10:26 AM ]
;;2.0;IHS RPMS/PCC Health Summary;**13**;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 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 '$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)"
S DIK="^APCHSCTL(" D IXALL^DIK
S DIK="^APCHSURV(" D IXALL^DIK
D ^APCHTX
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 ;
S APCHX="DM AUDIT 2 HR GTT TAX" D LAB1
S APCHX="BGP GPRA ESTIMATED GFR TAX" D LAB1
D SETTAXL
D ^APCHBU13
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
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
;;
APCH2P13 ; IHS/TUCSON/LAB - PCC HEALTH SUMMARY POST INIT PATCH 12 ; [ 09/07/04 10:26 AM ]
+1 ;;2.0;IHS RPMS/PCC Health Summary;**13**;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 KILL ^APCHTMP("HMR STATUS")
+7 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)
+8 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 SET X=$$ADD^XPDMENU("APCHSBLD","APCH SITE PARAMETER SETUP","HSSP")
+7 IF 'X
WRITE "Attempt to add health summary site parameter option failed."
HANG 3
+8 SET X=$$ADD^XPDMENU("APCHSMAINT","APCH SITE PARAMETER SETUP","HSSP")
+9 IF 'X
WRITE "Attempt to add health summary site parameter option failed."
HANG 3
+10 IF '$ORDER(^APCHSCMP("B","MEDS - CHRONIC & ACUTE W/ ISSU",0))
Begin DoDot:1
+11 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
+12 IF Y=-1
WRITE !!,"adding health summary component MEDS - CHRONIC & ACUTE W/ ISSUE HISTORY failed."
DO ^XBFMK
QUIT
+13 SET $PIECE(^APCHSCMP(+Y,0),U,2)="MEDSNDUP;APCHS78"
End DoDot:1
+14 IF '$ORDER(^APCHSCMP("B","MEDS - CHRONIC BY NAME",0))
Begin DoDot:1
+15 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
+16 IF Y=-1
WRITE !!,"adding health summary component MEDS - CHRONIC BY NAME failed."
DO ^XBFMK
QUIT
+17 SET $PIECE(^APCHSCMP(+Y,0),U,2)="MEDSCHRN;APCHS77"
End DoDot:1
+18 IF '$ORDER(^APCHSCMP("B","MEDS - CURRENT BY NAME",0))
Begin DoDot:1
+19 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
+20 IF Y=-1
WRITE !!,"adding health summary component MEDS - CURRENT BY NAME failed."
DO ^XBFMK
QUIT
+21 SET $PIECE(^APCHSCMP(+Y,0),U,2)="MEDSCURR;APCHS77"
End DoDot:1
+22 IF '$ORDER(^APCHSCMP("B","RADIOLOGY EXAMS",0))
Begin DoDot:1
+23 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
+24 IF Y=-1
WRITE !!,"adding health summary component RADIOLOGY failed."
DO ^XBFMK
QUIT
+25 SET $PIECE(^APCHSCMP(+Y,0),U,2)="RAD;APCHS3C"
End DoDot:1
+26 IF '$ORDER(^APCHSCMP("B","EDUCATIONAL ASSESSMENT",0))
Begin DoDot:1
+27 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
+28 IF Y=-1
WRITE !!,"adding health summary component EDUCATIONAL ASSESSMENT failed."
DO ^XBFMK
QUIT
+29 SET $PIECE(^APCHSCMP(+Y,0),U,2)="EDUCASSE;APCHS4A"
End DoDot:1
+30 IF '$ORDER(^APCHSCMP("B","INFANT FEEDING CHOICE PANEL",0))
Begin DoDot:1
+31 DO ^XBFMK
SET DIC="^APCHSCMP("
SET X="INFANT FEEDING CHOICE PANEL"
SET DIC(0)="L"
KILL DD,DO,D0
DO FILE^DICN
+32 IF Y=-1
WRITE !!,"adding health summary component INFANT FEEDING CHOICE PANEL failed."
DO ^XBFMK
QUIT
+33 SET $PIECE(^APCHSCMP(+Y,0),U,2)="BIRTHM;APCHS8"
End DoDot:1
+34 IF '$ORDER(^APCHSCMP("B","SCHEDULED ENCS (W/O CHART REQ ",0))
Begin DoDot:1
+35 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
+36 IF Y=-1
WRITE !!,"adding health summary component INFANT FEEDING CHOICE PANEL failed."
DO ^XBFMK
QUIT
+37 SET $PIECE(^APCHSCMP(+Y,0),U,2)="SCHENC;APCHS2J"
+38 SET $PIECE(^APCHSCMP(+Y,0),U,4)="SCHEDULED ENCOUNTERS (EXCLUDES CHART REQ AND WALK INS)"
End DoDot:1
+39 SET DIK="^APCHSCTL("
DO IXALL^DIK
+40 SET DIK="^APCHSURV("
DO IXALL^DIK
+41 DO ^APCHTX
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 SET APCHX=0
FOR
SET APCHX=$ORDER(^APCHTMP("HMR STATUS",APCHX))
IF APCHX'=+APCHX
QUIT
Begin DoDot:1
+35 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
+36 IF Y=-1
WRITE !!,"could not update status on ",X," hmr"
QUIT
+37 SET $PIECE(^APCHSURV(+Y,0),U,3)=APCHS
End DoDot:1
+38 IF '$$INSTALLD("APCH*2.00*11")
Begin DoDot:1
+39 SET DA=$ORDER(^APCHSURV("B","IHD-Elevated LDL Prompt",0))
+40 IF DA
SET DR=".03///I"
SET DIE="^APCHSURV("
DO ^DIE
KILL DIE,DA,DR
+41 SET DA=$ORDER(^APCHSURV("B","IHD-LDL Screening",0))
+42 IF DA
SET DR=".03///I"
SET DIE="^APCHSURV("
DO ^DIE
KILL DIE,DA,DR
+43 SET DA=$ORDER(^APCHSURV("B","ADULT MMR 1-DOSE VERSION",0))
+44 IF DA
SET DR=".03///I"
SET DIE="^APCHSURV("
DO ^DIE
KILL DIE,DA,DR
+45 SET DA=$ORDER(^APCHSURV("B","ADULT MMR 2-DOSE VERSION",0))
+46 IF DA
SET DR=".03///I"
SET DIE="^APCHSURV("
DO ^DIE
KILL DIE,DA,DR
+47 SET DA=$ORDER(^APCHSURV("B","RUBELLA VACCINATION",0))
+48 IF DA
SET DR=".03///I"
SET DIE="^APCHSURV("
DO ^DIE
KILL DIE,DA,DR
End DoDot:1
BUL ;
+1 SET APCHX="DM AUDIT 2 HR GTT TAX"
DO LAB1
+2 SET APCHX="BGP GPRA ESTIMATED GFR TAX"
DO LAB1
+3 DO SETTAXL
+4 DO ^APCHBU13
+5 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
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 ;;
