BJPC1EC1 ; IHS/CMI/LAB - PCC Suite v1.0 patch 1 environment check [ 04/10/2008 9:01 AM ]
;;1.0;IHS PCC SUITE;**1**;MAR 14, 2008
;
;
; 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
I '$$INSTALLD("ATX*5.1*10") D SORRY(2)
I '$$INSTALLD("AUPN*99.1*18") D SORRY(2)
I '$$INSTALLD("APCD*2.0*10") D SORRY(2)
I '$$INSTALLD("APCL*3.0*21") D SORRY(2)
I '$$INSTALLD("APCH*2.0*17") D SORRY(2)
I '$$INSTALLD("BDP*1.0*1") D SORRY(2)
I '$$INSTALLD("AMQQ*2.0*20") D SORRY(2)
I '$D(^DIC(9.4,"C","LEX")) D MES^XPDUTL($$CJ^XLFSTR("Lexicon is *NOT* installed.",IOM)) D SORRY(2)
;
Q
;
PRE ;
S BJPCX=0 F S BJPCX=$O(^APCLCNTL(BJPCX)) Q:BJPCX'=+BJPCX S DA=BJPCX,DIK="^APCLCNTL(" D ^DIK
F DA=1:1:900 S DIK="^APCLVSTS(" D ^DIK
S BJPCX=0 F S BJPCX=$O(^APCLDMTX(BJPCX)) Q:BJPCX'=+BJPCX S DA=BJPCX,DIK="^APCLDMTX(" D ^DIK
AS ;get rid of FEV1, FV1P
F BJPCMR="FEV1","FV1P","FVC","FVCP" S BJPCM=$O(^AUTTMSR("B",BJPCMR,0)) I BJPCM D
.S BJPCDA=0 F S BJPCDA=$O(^AUPNVMSR("B",BJPCM,BJPCDA)) Q:BJPCDA'=+BJPCDA S DA=BJPCDA,DIK="^AUPNVMSR(" D ^DIK
.S DA=BJPCM,DIK="^AUTTMSR(" D ^DIK
F BJPCMR="FEV1","FV1P","FVC","FVCP" S BJPCM=$O(^APCDTKW("B",BJPCMR,0)) I BJPCM S DA=BJPCM,DIK="^APCDTKW(" D ^DIK
;STUFF ALL EXISTING REMINDERS WITH R
S BJPCX=0 F S BJPCX=$O(^APCHSURV(BJPCX)) Q:BJPCX'=+BJPCX D
.Q:$P(^APCHSURV(BJPCX,0),U,7)]""
.Q:$P(^APCHSURV(BJPCX,0),U,7)="T"
.S $P(^APCHSURV(BJPCX,0),U,7)="R"
S DA=$O(^APCHSURV("B","ASTHMA - ADD/INCREASE INHALED ",0))
I DA S DIE="^APCHSURV(",DR=".01///ASTHMA - ADD/INCREASE INHALED STEROIDS" D ^DIE K DA,DIE
Q
POST ;
;;add new clinic code telebehavioral health
NEW DA,DIC,DR,DIE
S DA=$O(^DIC(40.7,"C","C9",0)) I 'DA D
.S DLAYGO=40.7,DIC(0)="L",DIC="^DIC(40.7,",X="TELEBEHAVIORAL HEALTH"
.K DD,D0,DO
.D FILE^DICN
.I Y=-1 D MES^XPDUTL($$CJ^XLFSTR("Adding Clinic TELEBEHAVIORAL HEALTH Failed.",IOM))
.S DA=+Y
.K DLAYGO,DIC,Y
I DA D
.S DIE="^DIC(40.7,",DR="1///C9;999999901///TEBH;90000.01///Y"
.D ^DIE
.I $D(Y) D MES^XPDUTL($$CJ^XLFSTR("Updating Clinic TELEBEHAVIORAL HEALTH Failed.",IOM))
K DA,DR,DIE
OPTIONS ;
S X=$$ADD^XPDMENU("APCDCAF EHR CODING AUDIT MENU","APCDCAF LIST INCOMPLETE","INCV")
I 'X W "Attempt to add coding queue incomplete visit option failed." H 3
S X=$$ADD^XPDMENU("APCHSMAINT","APCH TREATMENT PROMPT MENU","TP")
I 'X W "Attempt to add coding queue incomplete visit option failed." H 3
;
ASAMP ;
D MES^XPDUTL($$CJ^XLFSTR("Copying Asthma Management Plan to V Patient Education.",IOM))
S BJPCIEN=$O(^AUTTEDT("C","ASM-SMP",0))
I 'BJPCIEN D MES^XPDUTL($$CJ^XLFSTR("ASM-SMP education topic missing from file, cannot move data.",IOM)) G ASTRIGET
S BJPCX=0 F S BJPCX=$O(^AUPNVAST(BJPCX)) Q:BJPCX'=+BJPCX D
.Q:$P($G(^AUPNVAST(BJPCX,0)),U,12)="" ;no asthma management plan to copy
.Q:$P($G(^AUPNVAST(BJPCX,0)),U,12)'=1
.Q:$$HASASAMP($P(^AUPNVAST(BJPCX,0),U,3),BJPCIEN)
.K APCDALVR
.S APCDALVR("APCDVSIT")=$P(^AUPNVAST(BJPCX,0),U,3)
.S APCDALVR("APCDATMP")="[APCDALVR 9000010.16 (ADD)]"
.S APCDALVR("APCDTTOP")="`"_BJPCIEN
.S APCDALVR("APCDPAT")=$P(^AUPNVAST(BJPCX,0),U,2)
.D ^APCDALVR
.I $D(APCDALVR("APCDAFLG")) D MES^XPDUTL($$CJ^XLFSTR("Patient ed ASM-SMP failed for Visit "_$P(^AUPNVAST(BJPCX,0),U,3),IOM))
.K APCDALVR
ASTRIGET ;
D MES^XPDUTL($$CJ^XLFSTR("Copying Asthma Trigger ETS to V Health Factors.",IOM))
S BJPCIEN=$O(^AUTTHF("B","ASTHMA TRIGGER-TOBACCO SMOKE",0))
I 'BJPCIEN D MES^XPDUTL($$CJ^XLFSTR("ASTHMA TRIGGER-TOBACCO SMOKE missing from file, cannot move data.",IOM)) G ASTRIGPM
S BJPCX=0 F S BJPCX=$O(^AUPNVAST(BJPCX)) Q:BJPCX'=+BJPCX D
.Q:$P($G(^AUPNVAST(BJPCX,0)),U,8)'="Y" ;no asthma management plan to copy
.Q:$$HASASHF($P(^AUPNVAST(BJPCX,0),U,3),BJPCIEN)
.K APCDALVR
.S APCDALVR("APCDATMP")="[APCDALVR 9000010.23 (ADD)]"
.S APCDALVR("APCDTHF")="`"_BJPCIEN
.S APCDALVR("APCDVSIT")=$P(^AUPNVAST(BJPCX,0),U,3)
.S APCDALVR("APCDPAT")=$P(^AUPNVAST(BJPCX,0),U,2)
.D ^APCDALVR
.I $D(APCDALVR("APCDAFLG")) D MES^XPDUTL($$CJ^XLFSTR("Health Factor ASTHMA TRIGGERS-TOBACCO SMOKE failed for Visit "_$P(^AUPNVAST(BJPCX,0),U,3),IOM))
.K APCDALVR
ASTRIGPM ;
D MES^XPDUTL($$CJ^XLFSTR("Copying Asthma Trigger AIR POLLUTANTS to V Health Factors.",IOM))
S BJPCIEN=$O(^AUTTHF("B","ASTHMA TRIGGER-AIR POLLUTANTS",0))
I 'BJPCIEN D MES^XPDUTL($$CJ^XLFSTR("ASTHMA TRIGGER-AIR POLLUTANTS missing from file, cannot move data.",IOM)) G ASTRIGDM
S BJPCX=0 F S BJPCX=$O(^AUPNVAST(BJPCX)) Q:BJPCX'=+BJPCX D
.Q:$P($G(^AUPNVAST(BJPCX,0)),U,9)'="Y"
.Q:$$HASASHF($P(^AUPNVAST(BJPCX,0),U,3),BJPCIEN)
.K APCDALVR
.S APCDALVR("APCDATMP")="[APCDALVR 9000010.23 (ADD)]"
.S APCDALVR("APCDTHF")="`"_BJPCIEN
.S APCDALVR("APCDVSIT")=$P(^AUPNVAST(BJPCX,0),U,3)
.S APCDALVR("APCDPAT")=$P(^AUPNVAST(BJPCX,0),U,2)
.D ^APCDALVR
.I $D(APCDALVR("APCDAFLG")) D MES^XPDUTL($$CJ^XLFSTR("Health Factor ASTHMA TRIGGERS-AIR POLLUTANTS failed for Visit "_$P(^AUPNVAST(BJPCX,0),U,3),IOM))
.K APCDALVR
ASTRIGDM ;
D MES^XPDUTL($$CJ^XLFSTR("Copying Asthma Trigger DUST MITES to V Health Factors.",IOM))
S BJPCIEN=$O(^AUTTHF("B","ASTHMA TRIGGER-DUST MITES",0))
I 'BJPCIEN D MES^XPDUTL($$CJ^XLFSTR("ASTHMA TRIGGERS-DUST MITES missing from file, cannot move data.",IOM)) G ASMEAPEF
S BJPCX=0 F S BJPCX=$O(^AUPNVAST(BJPCX)) Q:BJPCX'=+BJPCX D
.Q:$P($G(^AUPNVAST(BJPCX,0)),U,11)'="Y"
.Q:$$HASASHF($P(^AUPNVAST(BJPCX,0),U,3),BJPCIEN)
.K APCDALVR
.S APCDALVR("APCDATMP")="[APCDALVR 9000010.23 (ADD)]"
.S APCDALVR("APCDTHF")="`"_BJPCIEN
.S APCDALVR("APCDVSIT")=$P(^AUPNVAST(BJPCX,0),U,3)
.S APCDALVR("APCDPAT")=$P(^AUPNVAST(BJPCX,0),U,2)
.D ^APCDALVR
.I $D(APCDALVR("APCDAFLG")) D MES^XPDUTL($$CJ^XLFSTR("Health Factor ASTHMA TRIGGER-DUST MITES failed for Visit "_$P(^AUPNVAST(BJPCX,0),U,3),IOM))
.K APCDALVR
ASMEAPEF ;
D MES^XPDUTL($$CJ^XLFSTR("Copying PEF/BEST PF to V Measurements.",IOM))
S BJPCIEN=$O(^AUTTMSR("B","BPF",0))
I 'BJPCIEN D MES^XPDUTL($$CJ^XLFSTR("BPF missing from file, cannot move data.",IOM)) G ASMEAFEF
S BJPCX=0 F S BJPCX=$O(^AUPNVAST(BJPCX)) Q:BJPCX'=+BJPCX D
.Q:$P($G(^AUPNVAST(BJPCX,0)),U,7)=""
.Q:$$HASASME($P(^AUPNVAST(BJPCX,0),U,3),BJPCIEN)
.K APCDALVR
.S APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]"
.S APCDALVR("APCDTTYP")="`"_BJPCIEN
.S APCDALVR("APCDTVAL")=$P(^AUPNVAST(BJPCX,0),U,7)
.S APCDALVR("APCDVSIT")=$P(^AUPNVAST(BJPCX,0),U,3)
.S APCDALVR("APCDPAT")=$P(^AUPNVAST(BJPCX,0),U,2)
.D ^APCDALVR
.I $D(APCDALVR("APCDAFLG")) D MES^XPDUTL($$CJ^XLFSTR("Measurement BPF failed for Visit "_$P(^AUPNVAST(BJPCX,0),U,3),IOM))
.K APCDALVR
ASMEAFEF ;
D MES^XPDUTL($$CJ^XLFSTR("Copying FEF 25-75 to V Measurements.",IOM))
S BJPCIEN=$O(^AUTTMSR("B","FEF",0))
I 'BJPCIEN D MES^XPDUTL($$CJ^XLFSTR("FEF missing from file, cannot move data.",IOM)) G ASMEAFEV
S BJPCX=0 F S BJPCX=$O(^AUPNVAST(BJPCX)) Q:BJPCX'=+BJPCX D
.Q:$P($G(^AUPNVAST(BJPCX,0)),U,6)=""
.Q:$$HASASME($P(^AUPNVAST(BJPCX,0),U,3),BJPCIEN)
.K APCDALVR
.S APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]"
.S APCDALVR("APCDTTYP")="`"_BJPCIEN
.S APCDALVR("APCDTVAL")=$P(^AUPNVAST(BJPCX,0),U,6)
.S APCDALVR("APCDVSIT")=$P(^AUPNVAST(BJPCX,0),U,3)
.S APCDALVR("APCDPAT")=$P(^AUPNVAST(BJPCX,0),U,2)
.D ^APCDALVR
.I $D(APCDALVR("APCDAFLG")) D MES^XPDUTL($$CJ^XLFSTR("Measurement FEF 25-75 failed for Visit "_$P(^AUPNVAST(BJPCX,0),U,3),IOM))
.K APCDALVR
ASMEAFEV ;
G NEXT
D MES^XPDUTL($$CJ^XLFSTR("Copying Fev1 % to V Measurements.",IOM))
S BJPCIEN=$O(^AUTTMSR("B","FV1P",0))
I 'BJPCIEN D MES^XPDUTL($$CJ^XLFSTR("FV1P missing from file, cannot move data.",IOM)) G NEXT
S BJPCX=0 F S BJPCX=$O(^AUPNVAST(BJPCX)) Q:BJPCX'=+BJPCX D
.Q:$P($G(^AUPNVAST(BJPCX,0)),U,5)=""
.Q:$$HASASME($P(^AUPNVAST(BJPCX,0),U,3),BJPCIEN)
.K APCDALVR
.S APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]"
.S APCDALVR("APCDTTYP")="`"_BJPCIEN
.S APCDALVR("APCDTVAL")=$P(^AUPNVAST(BJPCX,0),U,5)
.S APCDALVR("APCDVSIT")=$P(^AUPNVAST(BJPCX,0),U,3)
.S APCDALVR("APCDPAT")=$P(^AUPNVAST(BJPCX,0),U,2)
.D ^APCDALVR
.I $D(APCDALVR("APCDAFLG")) D MES^XPDUTL($$CJ^XLFSTR("Measurement FEV 1% failed for Visit "_$P(^AUPNVAST(BJPCX,0),U,3),IOM))
.K APCDALVR
NEXT ;
;FIX FH 8TH PIECE
S BJPCX=0 F S BJPCX=$O(^AUPNFH(BJPCX)) Q:BJPCX'=+BJPCX I '$P(^AUPNFH(BJPCX,0),U,8) S $P(^AUPNFH(BJPCX,0),U,8)=""
;
MOVEFH ;move Family History problem entries to fh
D MES^XPDUTL($$CJ^XLFSTR("Copying Family History Problem entries to Family History.",IOM))
S BJPCX=0 F S BJPCX=$O(^AUPNPROB(BJPCX)) Q:BJPCX'=+BJPCX D
.Q:$P(^AUPNPROB(BJPCX,0),U,4)'="F"
.;CREATE FAMILY HX ENTRY
.S P=$P(^AUPNPROB(BJPCX,0),U,2)
.Q:'P
.S X=$P(^AUPNPROB(BJPCX,0),U)
.Q:'X
.S N=$P(^AUPNPROB(BJPCX,0),U,5)
.I '$$HASFH(P,X,N) D
..S DIC="^AUPNFH("
..S DLAYGO=9000014
..S DIADD=1
..S DIC("DR")=".02////"_P_";.03////"_$P(^AUPNPROB(BJPCX,0),U,8)_";.04////"_N_";.08////"_$P($G(^AUPNPROB(1,1)),U,4)
..S DIC(0)="L"
..K DD,D0,DO
..D FILE^DICN
..I Y=-1 D MES^XPDUTL("Error creating family history entry for problem entry "_BJPCX) K DIC,DIADD,DLAYGO Q
..K DIC,DIADD,DLAYGO
..;S DA=BJPCX,DIK="^AUPNPROB(" D ^DIK K DA,DIK DO NOT DELETE PER HOWARD ON CCB CALL 1/31/08
..Q
DELAST ;
;delete ast and hast mnemonics
S DA=$O(^APCDTKW("B","AST",0)) I DA S DIK="^APCDTKW(" D ^DIK
S DA=$O(^APCDTKW("B","HAST",0)) I DA S DIK="^APCDTKW(" D ^DIK
;
;now "delete" anmc reminders
S DA=$O(^APCHSURV("B","ANMC COLORECTAL",0))
I DA S DIE="^APCHSURV(",DR=".03///D" D ^DIE K DIE,DA,DR
S DA=$O(^APCHSURV("B","ANMC COLORECTAL CANCER",0))
I DA S DIE="^APCHSURV(",DR=".03///D" D ^DIE K DIE,DA,DR
S DA=$O(^APCHSURV("B","ANMC DEPRESSION SCREEN",0))
I DA S DIE="^APCHSURV(",DR=".03///D" D ^DIE K DIE,DA,DR
S DA=$O(^APCHSURV("B","REHAB/FUNCTIONAL SCREEN",0))
I DA S DIE="^APCHSURV(",DR=".03///D" D ^DIE K DIE,DA,DR
;
D ^BJPCTX
D ^BJPC1ECA
S DA=$O(^APCDSTGC("B","DIABETIC RETINOPATHY",0))
I DA S DIE="^APCDSTGC(",DR=".02///APCD DIABETIC RETINOPATHY DXS" D ^DIE K DA,DIE
;
D HOME^%ZIS,DT^DICRW
;
NEW XMSUB,XMDUZ,XMTEXT,XMY,DIFROM
KILL ^TMP($J,"BJPCBUL")
D WRITEMSG,GETRECIP
;Change following lines as desired
SUBJECT S XMSUB="* * * IMPORTANT RPMS INFORMATION * * *"
SENDER S XMDUZ="Cimarron Medical Informatics"
S XMTEXT="^TMP($J,""BJPCBUL"",",XMY(1)="",XMY(DUZ)=""
I $E(IOST)="C" W !,"Sending Mailman message to PCC Users."
D ^XMD
KILL ^TMP($J,"BJPCBUL"),BJPCKEY
Q
;
WRITEMSG ;
S X=$O(^APCLPDES("B","BJPCV1P1",0))
Q:'X
S Y=0 F S Y=$O(^APCLPDES(X,11,Y)) Q:Y'=+Y S ^TMP($J,"BJPCBUL",Y)=^APCLPDES(X,11,Y,0)
Q
;
GETRECIP ;
;
S CTR=0
F BJPCKEY="APCLZMENU","APCDZMENU","APCHZMENU","BDPZMENU","AMQQZMENU"
F S CTR=$O(^XUSEC(BJPCKEY,CTR)) Q:'CTR S Y=CTR S XMY(Y)=""
Q
INSTALLD(BJPCSTAL) ;EP - Determine if patch BJPCSTAL was installed, where
; APCLSTAL is the name of the INSTALL. E.g "AG*6.0*11".
;
NEW BJPCY,DIC,X,Y
S X=$P(BJPCSTAL,"*",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(BJPCSTAL,"*",2)
D ^DIC
I Y<1 D IMES Q 0
S DIC=DIC_+Y_",""PAH"",",X=$P(BJPCSTAL,"*",3)
D ^DIC
S BJPCY=Y
D IMES
Q $S(BJPCY<1:0,1:1)
IMES ;
D MES^XPDUTL($$CJ^XLFSTR("Patch """_BJPCSTAL_""" is"_$S(Y<1:" *NOT*",1:"")_" installed.",IOM))
Q
SORRY(X) ;
KILL DIFQ
I X=3 S XPDQUIT=2 Q
S XPDQUIT=X
W *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
Q
;
CLINNEW ;;H. NEW CLINIC CODES (SECTION XIX): CODE^NAME^ABBRV^PRIMARY CARE CLINIC^1A WORKLOAD
;;C8^TELEBEHAVIORAL HEALTH^TEBH^N^Y
;;END
;
HASASAMP(V,I) ;is there a v patient ed of ASM-SMP?
NEW X,Y,Z
S (X,Z)=0 F S X=$O(^AUPNVPED("AD",V,X)) Q:X'=+X D
.I $P($G(^AUPNVPED(X,0)),U)=I S Z=1
.Q
Q Z
;
HASASHF(V,I) ;
NEW X,Y,Z
S (X,Z)=0 F S X=$O(^AUPNVHF("AD",V,X)) Q:X'=+X D
.I $P($G(^AUPNVHF(X,0)),U)=I S Z=1
.Q
Q Z
;
HASASME(V,I) ;is there a v MEASUREMENT I?
NEW X,Y,Z
S (X,Z)=0 F S X=$O(^AUPNVMSR("AD",V,X)) Q:X'=+X D
.I $P($G(^AUPNVMSR(X,0)),U)=I S Z=1
.Q
Q Z
;
HASFH(P,I,N) ;
NEW X,Y,Z
S (X,Z)=0 F S X=$O(^AUPNFH("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNFH(X,0))
.I $P(^AUPNFH(X,0),U,1)=I,$P(^AUPNFH(X,0),U,4)=N S Z=1
.Q
Q Z
;
BJPC1EC1 ; IHS/CMI/LAB - PCC Suite v1.0 patch 1 environment check [ 04/10/2008 9:01 AM ]
+1 ;;1.0;IHS PCC SUITE;**1**;MAR 14, 2008
+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 IF '$$INSTALLD("ATX*5.1*10")
DO SORRY(2)
+9 IF '$$INSTALLD("AUPN*99.1*18")
DO SORRY(2)
+10 IF '$$INSTALLD("APCD*2.0*10")
DO SORRY(2)
+11 IF '$$INSTALLD("APCL*3.0*21")
DO SORRY(2)
+12 IF '$$INSTALLD("APCH*2.0*17")
DO SORRY(2)
+13 IF '$$INSTALLD("BDP*1.0*1")
DO SORRY(2)
+14 IF '$$INSTALLD("AMQQ*2.0*20")
DO SORRY(2)
+15 IF '$DATA(^DIC(9.4,"C","LEX"))
DO MES^XPDUTL($$CJ^XLFSTR("Lexicon is *NOT* installed.",IOM))
DO SORRY(2)
+16 ;
+17 QUIT
+18 ;
PRE ;
+1 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^APCLCNTL(BJPCX))
IF BJPCX'=+BJPCX
QUIT
SET DA=BJPCX
SET DIK="^APCLCNTL("
DO ^DIK
+2 FOR DA=1:1:900
SET DIK="^APCLVSTS("
DO ^DIK
+3 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^APCLDMTX(BJPCX))
IF BJPCX'=+BJPCX
QUIT
SET DA=BJPCX
SET DIK="^APCLDMTX("
DO ^DIK
AS ;get rid of FEV1, FV1P
+1 FOR BJPCMR="FEV1","FV1P","FVC","FVCP"
SET BJPCM=$ORDER(^AUTTMSR("B",BJPCMR,0))
IF BJPCM
Begin DoDot:1
+2 SET BJPCDA=0
FOR
SET BJPCDA=$ORDER(^AUPNVMSR("B",BJPCM,BJPCDA))
IF BJPCDA'=+BJPCDA
QUIT
SET DA=BJPCDA
SET DIK="^AUPNVMSR("
DO ^DIK
+3 SET DA=BJPCM
SET DIK="^AUTTMSR("
DO ^DIK
End DoDot:1
+4 FOR BJPCMR="FEV1","FV1P","FVC","FVCP"
SET BJPCM=$ORDER(^APCDTKW("B",BJPCMR,0))
IF BJPCM
SET DA=BJPCM
SET DIK="^APCDTKW("
DO ^DIK
+5 ;STUFF ALL EXISTING REMINDERS WITH R
+6 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^APCHSURV(BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:1
+7 IF $PIECE(^APCHSURV(BJPCX,0),U,7)]""
QUIT
+8 IF $PIECE(^APCHSURV(BJPCX,0),U,7)="T"
QUIT
+9 SET $PIECE(^APCHSURV(BJPCX,0),U,7)="R"
End DoDot:1
+10 SET DA=$ORDER(^APCHSURV("B","ASTHMA - ADD/INCREASE INHALED ",0))
+11 IF DA
SET DIE="^APCHSURV("
SET DR=".01///ASTHMA - ADD/INCREASE INHALED STEROIDS"
DO ^DIE
KILL DA,DIE
+12 QUIT
POST ;
+1 ;;add new clinic code telebehavioral health
+2 NEW DA,DIC,DR,DIE
+3 SET DA=$ORDER(^DIC(40.7,"C","C9",0))
IF 'DA
Begin DoDot:1
+4 SET DLAYGO=40.7
SET DIC(0)="L"
SET DIC="^DIC(40.7,"
SET X="TELEBEHAVIORAL HEALTH"
+5 KILL DD,D0,DO
+6 DO FILE^DICN
+7 IF Y=-1
DO MES^XPDUTL($$CJ^XLFSTR("Adding Clinic TELEBEHAVIORAL HEALTH Failed.",IOM))
+8 SET DA=+Y
+9 KILL DLAYGO,DIC,Y
End DoDot:1
+10 IF DA
Begin DoDot:1
+11 SET DIE="^DIC(40.7,"
SET DR="1///C9;999999901///TEBH;90000.01///Y"
+12 DO ^DIE
+13 IF $DATA(Y)
DO MES^XPDUTL($$CJ^XLFSTR("Updating Clinic TELEBEHAVIORAL HEALTH Failed.",IOM))
End DoDot:1
+14 KILL DA,DR,DIE
OPTIONS ;
+1 SET X=$$ADD^XPDMENU("APCDCAF EHR CODING AUDIT MENU","APCDCAF LIST INCOMPLETE","INCV")
+2 IF 'X
WRITE "Attempt to add coding queue incomplete visit option failed."
HANG 3
+3 SET X=$$ADD^XPDMENU("APCHSMAINT","APCH TREATMENT PROMPT MENU","TP")
+4 IF 'X
WRITE "Attempt to add coding queue incomplete visit option failed."
HANG 3
+5 ;
ASAMP ;
+1 DO MES^XPDUTL($$CJ^XLFSTR("Copying Asthma Management Plan to V Patient Education.",IOM))
+2 SET BJPCIEN=$ORDER(^AUTTEDT("C","ASM-SMP",0))
+3 IF 'BJPCIEN
DO MES^XPDUTL($$CJ^XLFSTR("ASM-SMP education topic missing from file, cannot move data.",IOM))
GOTO ASTRIGET
+4 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUPNVAST(BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:1
+5 ;no asthma management plan to copy
IF $PIECE($GET(^AUPNVAST(BJPCX,0)),U,12)=""
QUIT
+6 IF $PIECE($GET(^AUPNVAST(BJPCX,0)),U,12)'=1
QUIT
+7 IF $$HASASAMP($PIECE(^AUPNVAST(BJPCX,0),U,3),BJPCIEN)
QUIT
+8 KILL APCDALVR
+9 SET APCDALVR("APCDVSIT")=$PIECE(^AUPNVAST(BJPCX,0),U,3)
+10 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.16 (ADD)]"
+11 SET APCDALVR("APCDTTOP")="`"_BJPCIEN
+12 SET APCDALVR("APCDPAT")=$PIECE(^AUPNVAST(BJPCX,0),U,2)
+13 DO ^APCDALVR
+14 IF $DATA(APCDALVR("APCDAFLG"))
DO MES^XPDUTL($$CJ^XLFSTR("Patient ed ASM-SMP failed for Visit "_$PIECE(^AUPNVAST(BJPCX,0),U,3),IOM))
+15 KILL APCDALVR
End DoDot:1
ASTRIGET ;
+1 DO MES^XPDUTL($$CJ^XLFSTR("Copying Asthma Trigger ETS to V Health Factors.",IOM))
+2 SET BJPCIEN=$ORDER(^AUTTHF("B","ASTHMA TRIGGER-TOBACCO SMOKE",0))
+3 IF 'BJPCIEN
DO MES^XPDUTL($$CJ^XLFSTR("ASTHMA TRIGGER-TOBACCO SMOKE missing from file, cannot move data.",IOM))
GOTO ASTRIGPM
+4 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUPNVAST(BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:1
+5 ;no asthma management plan to copy
IF $PIECE($GET(^AUPNVAST(BJPCX,0)),U,8)'="Y"
QUIT
+6 IF $$HASASHF($PIECE(^AUPNVAST(BJPCX,0),U,3),BJPCIEN)
QUIT
+7 KILL APCDALVR
+8 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.23 (ADD)]"
+9 SET APCDALVR("APCDTHF")="`"_BJPCIEN
+10 SET APCDALVR("APCDVSIT")=$PIECE(^AUPNVAST(BJPCX,0),U,3)
+11 SET APCDALVR("APCDPAT")=$PIECE(^AUPNVAST(BJPCX,0),U,2)
+12 DO ^APCDALVR
+13 IF $DATA(APCDALVR("APCDAFLG"))
DO MES^XPDUTL($$CJ^XLFSTR("Health Factor ASTHMA TRIGGERS-TOBACCO SMOKE failed for Visit "_$PIECE(^AUPNVAST(BJPCX,0),U,3),IOM))
+14 KILL APCDALVR
End DoDot:1
ASTRIGPM ;
+1 DO MES^XPDUTL($$CJ^XLFSTR("Copying Asthma Trigger AIR POLLUTANTS to V Health Factors.",IOM))
+2 SET BJPCIEN=$ORDER(^AUTTHF("B","ASTHMA TRIGGER-AIR POLLUTANTS",0))
+3 IF 'BJPCIEN
DO MES^XPDUTL($$CJ^XLFSTR("ASTHMA TRIGGER-AIR POLLUTANTS missing from file, cannot move data.",IOM))
GOTO ASTRIGDM
+4 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUPNVAST(BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:1
+5 IF $PIECE($GET(^AUPNVAST(BJPCX,0)),U,9)'="Y"
QUIT
+6 IF $$HASASHF($PIECE(^AUPNVAST(BJPCX,0),U,3),BJPCIEN)
QUIT
+7 KILL APCDALVR
+8 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.23 (ADD)]"
+9 SET APCDALVR("APCDTHF")="`"_BJPCIEN
+10 SET APCDALVR("APCDVSIT")=$PIECE(^AUPNVAST(BJPCX,0),U,3)
+11 SET APCDALVR("APCDPAT")=$PIECE(^AUPNVAST(BJPCX,0),U,2)
+12 DO ^APCDALVR
+13 IF $DATA(APCDALVR("APCDAFLG"))
DO MES^XPDUTL($$CJ^XLFSTR("Health Factor ASTHMA TRIGGERS-AIR POLLUTANTS failed for Visit "_$PIECE(^AUPNVAST(BJPCX,0),U,3),IOM))
+14 KILL APCDALVR
End DoDot:1
ASTRIGDM ;
+1 DO MES^XPDUTL($$CJ^XLFSTR("Copying Asthma Trigger DUST MITES to V Health Factors.",IOM))
+2 SET BJPCIEN=$ORDER(^AUTTHF("B","ASTHMA TRIGGER-DUST MITES",0))
+3 IF 'BJPCIEN
DO MES^XPDUTL($$CJ^XLFSTR("ASTHMA TRIGGERS-DUST MITES missing from file, cannot move data.",IOM))
GOTO ASMEAPEF
+4 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUPNVAST(BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:1
+5 IF $PIECE($GET(^AUPNVAST(BJPCX,0)),U,11)'="Y"
QUIT
+6 IF $$HASASHF($PIECE(^AUPNVAST(BJPCX,0),U,3),BJPCIEN)
QUIT
+7 KILL APCDALVR
+8 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.23 (ADD)]"
+9 SET APCDALVR("APCDTHF")="`"_BJPCIEN
+10 SET APCDALVR("APCDVSIT")=$PIECE(^AUPNVAST(BJPCX,0),U,3)
+11 SET APCDALVR("APCDPAT")=$PIECE(^AUPNVAST(BJPCX,0),U,2)
+12 DO ^APCDALVR
+13 IF $DATA(APCDALVR("APCDAFLG"))
DO MES^XPDUTL($$CJ^XLFSTR("Health Factor ASTHMA TRIGGER-DUST MITES failed for Visit "_$PIECE(^AUPNVAST(BJPCX,0),U,3),IOM))
+14 KILL APCDALVR
End DoDot:1
ASMEAPEF ;
+1 DO MES^XPDUTL($$CJ^XLFSTR("Copying PEF/BEST PF to V Measurements.",IOM))
+2 SET BJPCIEN=$ORDER(^AUTTMSR("B","BPF",0))
+3 IF 'BJPCIEN
DO MES^XPDUTL($$CJ^XLFSTR("BPF missing from file, cannot move data.",IOM))
GOTO ASMEAFEF
+4 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUPNVAST(BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:1
+5 IF $PIECE($GET(^AUPNVAST(BJPCX,0)),U,7)=""
QUIT
+6 IF $$HASASME($PIECE(^AUPNVAST(BJPCX,0),U,3),BJPCIEN)
QUIT
+7 KILL APCDALVR
+8 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]"
+9 SET APCDALVR("APCDTTYP")="`"_BJPCIEN
+10 SET APCDALVR("APCDTVAL")=$PIECE(^AUPNVAST(BJPCX,0),U,7)
+11 SET APCDALVR("APCDVSIT")=$PIECE(^AUPNVAST(BJPCX,0),U,3)
+12 SET APCDALVR("APCDPAT")=$PIECE(^AUPNVAST(BJPCX,0),U,2)
+13 DO ^APCDALVR
+14 IF $DATA(APCDALVR("APCDAFLG"))
DO MES^XPDUTL($$CJ^XLFSTR("Measurement BPF failed for Visit "_$PIECE(^AUPNVAST(BJPCX,0),U,3),IOM))
+15 KILL APCDALVR
End DoDot:1
ASMEAFEF ;
+1 DO MES^XPDUTL($$CJ^XLFSTR("Copying FEF 25-75 to V Measurements.",IOM))
+2 SET BJPCIEN=$ORDER(^AUTTMSR("B","FEF",0))
+3 IF 'BJPCIEN
DO MES^XPDUTL($$CJ^XLFSTR("FEF missing from file, cannot move data.",IOM))
GOTO ASMEAFEV
+4 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUPNVAST(BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:1
+5 IF $PIECE($GET(^AUPNVAST(BJPCX,0)),U,6)=""
QUIT
+6 IF $$HASASME($PIECE(^AUPNVAST(BJPCX,0),U,3),BJPCIEN)
QUIT
+7 KILL APCDALVR
+8 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]"
+9 SET APCDALVR("APCDTTYP")="`"_BJPCIEN
+10 SET APCDALVR("APCDTVAL")=$PIECE(^AUPNVAST(BJPCX,0),U,6)
+11 SET APCDALVR("APCDVSIT")=$PIECE(^AUPNVAST(BJPCX,0),U,3)
+12 SET APCDALVR("APCDPAT")=$PIECE(^AUPNVAST(BJPCX,0),U,2)
+13 DO ^APCDALVR
+14 IF $DATA(APCDALVR("APCDAFLG"))
DO MES^XPDUTL($$CJ^XLFSTR("Measurement FEF 25-75 failed for Visit "_$PIECE(^AUPNVAST(BJPCX,0),U,3),IOM))
+15 KILL APCDALVR
End DoDot:1
ASMEAFEV ;
+1 GOTO NEXT
+2 DO MES^XPDUTL($$CJ^XLFSTR("Copying Fev1 % to V Measurements.",IOM))
+3 SET BJPCIEN=$ORDER(^AUTTMSR("B","FV1P",0))
+4 IF 'BJPCIEN
DO MES^XPDUTL($$CJ^XLFSTR("FV1P missing from file, cannot move data.",IOM))
GOTO NEXT
+5 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUPNVAST(BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(^AUPNVAST(BJPCX,0)),U,5)=""
QUIT
+7 IF $$HASASME($PIECE(^AUPNVAST(BJPCX,0),U,3),BJPCIEN)
QUIT
+8 KILL APCDALVR
+9 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]"
+10 SET APCDALVR("APCDTTYP")="`"_BJPCIEN
+11 SET APCDALVR("APCDTVAL")=$PIECE(^AUPNVAST(BJPCX,0),U,5)
+12 SET APCDALVR("APCDVSIT")=$PIECE(^AUPNVAST(BJPCX,0),U,3)
+13 SET APCDALVR("APCDPAT")=$PIECE(^AUPNVAST(BJPCX,0),U,2)
+14 DO ^APCDALVR
+15 IF $DATA(APCDALVR("APCDAFLG"))
DO MES^XPDUTL($$CJ^XLFSTR("Measurement FEV 1% failed for Visit "_$PIECE(^AUPNVAST(BJPCX,0),U,3),IOM))
+16 KILL APCDALVR
End DoDot:1
NEXT ;
+1 ;FIX FH 8TH PIECE
+2 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUPNFH(BJPCX))
IF BJPCX'=+BJPCX
QUIT
IF '$PIECE(^AUPNFH(BJPCX,0),U,8)
SET $PIECE(^AUPNFH(BJPCX,0),U,8)=""
+3 ;
MOVEFH ;move Family History problem entries to fh
+1 DO MES^XPDUTL($$CJ^XLFSTR("Copying Family History Problem entries to Family History.",IOM))
+2 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUPNPROB(BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:1
+3 IF $PIECE(^AUPNPROB(BJPCX,0),U,4)'="F"
QUIT
+4 ;CREATE FAMILY HX ENTRY
+5 SET P=$PIECE(^AUPNPROB(BJPCX,0),U,2)
+6 IF 'P
QUIT
+7 SET X=$PIECE(^AUPNPROB(BJPCX,0),U)
+8 IF 'X
QUIT
+9 SET N=$PIECE(^AUPNPROB(BJPCX,0),U,5)
+10 IF '$$HASFH(P,X,N)
Begin DoDot:2
+11 SET DIC="^AUPNFH("
+12 SET DLAYGO=9000014
+13 SET DIADD=1
+14 SET DIC("DR")=".02////"_P_";.03////"_$PIECE(^AUPNPROB(BJPCX,0),U,8)_";.04////"_N_";.08////"_$PIECE($GET(^AUPNPROB(1,1)),U,4)
+15 SET DIC(0)="L"
+16 KILL DD,D0,DO
+17 DO FILE^DICN
+18 IF Y=-1
DO MES^XPDUTL("Error creating family history entry for problem entry "_BJPCX)
KILL DIC,DIADD,DLAYGO
QUIT
+19 KILL DIC,DIADD,DLAYGO
+20 ;S DA=BJPCX,DIK="^AUPNPROB(" D ^DIK K DA,DIK DO NOT DELETE PER HOWARD ON CCB CALL 1/31/08
+21 QUIT
End DoDot:2
End DoDot:1
DELAST ;
+1 ;delete ast and hast mnemonics
+2 SET DA=$ORDER(^APCDTKW("B","AST",0))
IF DA
SET DIK="^APCDTKW("
DO ^DIK
+3 SET DA=$ORDER(^APCDTKW("B","HAST",0))
IF DA
SET DIK="^APCDTKW("
DO ^DIK
+4 ;
+5 ;now "delete" anmc reminders
+6 SET DA=$ORDER(^APCHSURV("B","ANMC COLORECTAL",0))
+7 IF DA
SET DIE="^APCHSURV("
SET DR=".03///D"
DO ^DIE
KILL DIE,DA,DR
+8 SET DA=$ORDER(^APCHSURV("B","ANMC COLORECTAL CANCER",0))
+9 IF DA
SET DIE="^APCHSURV("
SET DR=".03///D"
DO ^DIE
KILL DIE,DA,DR
+10 SET DA=$ORDER(^APCHSURV("B","ANMC DEPRESSION SCREEN",0))
+11 IF DA
SET DIE="^APCHSURV("
SET DR=".03///D"
DO ^DIE
KILL DIE,DA,DR
+12 SET DA=$ORDER(^APCHSURV("B","REHAB/FUNCTIONAL SCREEN",0))
+13 IF DA
SET DIE="^APCHSURV("
SET DR=".03///D"
DO ^DIE
KILL DIE,DA,DR
+14 ;
+15 DO ^BJPCTX
+16 DO ^BJPC1ECA
+17 SET DA=$ORDER(^APCDSTGC("B","DIABETIC RETINOPATHY",0))
+18 IF DA
SET DIE="^APCDSTGC("
SET DR=".02///APCD DIABETIC RETINOPATHY DXS"
DO ^DIE
KILL DA,DIE
+19 ;
+20 DO HOME^%ZIS
DO DT^DICRW
+21 ;
+22 NEW XMSUB,XMDUZ,XMTEXT,XMY,DIFROM
+23 KILL ^TMP($JOB,"BJPCBUL")
+24 DO WRITEMSG
DO GETRECIP
+25 ;Change following lines as desired
SUBJECT SET XMSUB="* * * IMPORTANT RPMS INFORMATION * * *"
SENDER SET XMDUZ="Cimarron Medical Informatics"
+1 SET XMTEXT="^TMP($J,""BJPCBUL"","
SET XMY(1)=""
SET XMY(DUZ)=""
+2 IF $EXTRACT(IOST)="C"
WRITE !,"Sending Mailman message to PCC Users."
+3 DO ^XMD
+4 KILL ^TMP($JOB,"BJPCBUL"),BJPCKEY
+5 QUIT
+6 ;
WRITEMSG ;
+1 SET X=$ORDER(^APCLPDES("B","BJPCV1P1",0))
+2 IF 'X
QUIT
+3 SET Y=0
FOR
SET Y=$ORDER(^APCLPDES(X,11,Y))
IF Y'=+Y
QUIT
SET ^TMP($JOB,"BJPCBUL",Y)=^APCLPDES(X,11,Y,0)
+4 QUIT
+5 ;
GETRECIP ;
+1 ;
+2 SET CTR=0
+3 FOR BJPCKEY="APCLZMENU","APCDZMENU","APCHZMENU","BDPZMENU","AMQQZMENU"
+4 FOR
SET CTR=$ORDER(^XUSEC(BJPCKEY,CTR))
IF 'CTR
QUIT
SET Y=CTR
SET XMY(Y)=""
+5 QUIT
INSTALLD(BJPCSTAL) ;EP - Determine if patch BJPCSTAL was installed, where
+1 ; APCLSTAL is the name of the INSTALL. E.g "AG*6.0*11".
+2 ;
+3 NEW BJPCY,DIC,X,Y
+4 SET X=$PIECE(BJPCSTAL,"*",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(BJPCSTAL,"*",2)
+9 DO ^DIC
+10 IF Y<1
DO IMES
QUIT 0
+11 SET DIC=DIC_+Y_",""PAH"","
SET X=$PIECE(BJPCSTAL,"*",3)
+12 DO ^DIC
+13 SET BJPCY=Y
+14 DO IMES
+15 QUIT $SELECT(BJPCY<1:0,1:1)
IMES ;
+1 DO MES^XPDUTL($$CJ^XLFSTR("Patch """_BJPCSTAL_""" is"_$SELECT(Y<1:" *NOT*",1:"")_" installed.",IOM))
+2 QUIT
SORRY(X) ;
+1 KILL DIFQ
+2 IF X=3
SET XPDQUIT=2
QUIT
+3 SET XPDQUIT=X
+4 WRITE *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
+5 QUIT
+6 ;
CLINNEW ;;H. NEW CLINIC CODES (SECTION XIX): CODE^NAME^ABBRV^PRIMARY CARE CLINIC^1A WORKLOAD
+1 ;;C8^TELEBEHAVIORAL HEALTH^TEBH^N^Y
+2 ;;END
+3 ;
HASASAMP(V,I) ;is there a v patient ed of ASM-SMP?
+1 NEW X,Y,Z
+2 SET (X,Z)=0
FOR
SET X=$ORDER(^AUPNVPED("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^AUPNVPED(X,0)),U)=I
SET Z=1
+4 QUIT
End DoDot:1
+5 QUIT Z
+6 ;
HASASHF(V,I) ;
+1 NEW X,Y,Z
+2 SET (X,Z)=0
FOR
SET X=$ORDER(^AUPNVHF("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^AUPNVHF(X,0)),U)=I
SET Z=1
+4 QUIT
End DoDot:1
+5 QUIT Z
+6 ;
HASASME(V,I) ;is there a v MEASUREMENT I?
+1 NEW X,Y,Z
+2 SET (X,Z)=0
FOR
SET X=$ORDER(^AUPNVMSR("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^AUPNVMSR(X,0)),U)=I
SET Z=1
+4 QUIT
End DoDot:1
+5 QUIT Z
+6 ;
HASFH(P,I,N) ;
+1 NEW X,Y,Z
+2 SET (X,Z)=0
FOR
SET X=$ORDER(^AUPNFH("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+3 IF '$DATA(^AUPNFH(X,0))
QUIT
+4 IF $PIECE(^AUPNFH(X,0),U,1)=I
IF $PIECE(^AUPNFH(X,0),U,4)=N
SET Z=1
+5 QUIT
End DoDot:1
+6 QUIT Z
+7 ;
