BJPC2PMU ; IHS/CMI/LAB - PCC Suite v2.0 patch 10 environment check ;
;;2.0;IHS PCC SUITE;**10**;MAY 14, 2009;Build 88
;
;
; 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
;KERNEL
I +$$VERSION^XPDUTL("XU")<8 D MES^XPDUTL($$CJ^XLFSTR("Version 8.0 of KERNEL is required. Not installed",80)) D SORRY(2) I 1
E D MES^XPDUTL($$CJ^XLFSTR("Requires Kernel Version 8.0....Present.",80))
;FILEMAN
I +$$VERSION^XPDUTL("DI")<22 D MES^XPDUTL($$CJ^XLFSTR("Version 22.0 of FILEMAN is required. Not installed.",80)) D SORRY(2) I 1
E D MES^XPDUTL($$CJ^XLFSTR("Requires Fileman v22....Present.",80))
;BJPC
I $$VERSION^XPDUTL("BJPC")'="2.0" D MES^XPDUTL($$CJ^XLFSTR("Version 2.0 of the IHS PCC SUITE (BJPC) is required. Not installed",80)) D SORRY(2) I 1
E D MES^XPDUTL($$CJ^XLFSTR("Requires IHS PCC Suite (BJPC) Version 2.0....Present.",80))
I '$$INSTALLD("BJPC*2.0*8") D SORRY(2)
I '$$INSTALLD("BJPC*2.0*9") D SORRY(2)
I '$$INSTALLD("AVA*93.2*22") D SORRY(2)
I '$$INSTALLD("AUT*98.1*26") D SORRY(2)
I '$$INSTALLD("AUPN*99.1*23") D SORRY(2)
I '$$INSTALLD("AUM*13.0*2") D SORRY(2)
I '$$INSTALLD("AUM*13.0*3") D SORRY(2)
I +$$VERSION^XPDUTL("BCQM")<1 D MES^XPDUTL($$CJ^XLFSTR("Version 1.0 of BCQM - IHS CODE MAPPING is required. Not installed",80)) D SORRY(2) I 1
E D MES^XPDUTL($$CJ^XLFSTR("Requires BCQM V1.0....Present.",80))
I +$$VERSION^XPDUTL("BSTS")<1 D MES^XPDUTL($$CJ^XLFSTR("Version 1.0 of BSTS - IHS TERMINOLOGY is required. Not installed",80)) D SORRY(2) I 1
E D MES^XPDUTL($$CJ^XLFSTR("Requires BSTS V1.0....Present.",80))
I '$$INSTALLD("AG*7.1*11") D SORRY(2)
Q
PRE ;
;get rid of v care planning
S DIU=9000010.57,DIU(0)="DET" D EN^DIU2 K DIU
S DIU=9000010.59,DIU(0)="E" D EN^DIU2 K DIU
S DIU=9000010.61,DIU(0)="E" D EN^DIU2 K DIU
S DIU=9000010.63,DIU(0)="E" D EN^DIU2 K DIU
S DA=$O(^AUTTREFR("B","410561003",0))
I DA S DIE="^AUTTREFR(",DR=".01///410534003" D ^DIE K DA,DR,DIE
S BJPCOS=$O(^APCHSURV("B","OSTEOPOROSIS SCREENING",0))
I BJPCOS S BJPCOS=$P(^APCHSURV(BJPCOS,0),U,3)
;FIX 2101 MULTIPLE IN REPRODUCTIVE FACTORS
S DA=0 F S DA=$O(^AUPNREP(DA)) Q:DA'=+DA D
.Q:'$D(^AUPNREP(DA,2101,0))
.I $P(^AUPNREP(DA,2101,0),U,2)="S" S $P(^AUPNREP(DA,2101,0),U,2)="9000017.0201PA"
Q
;
POST ;
;add refusal type SNOMED to refusal type file
I '$D(^AUTTREFT("B","SNOMED")) D
.K DIC,DR,D0,DO
.S X="SNOMED",DIC="^AUTTREFT(",DIC("DR")=".02////9002318.4;.03////1",DIC(0)="L",DIADD=1,DLAYGO=9999999.73 D FILE^DICN K DIC,DIADD,DLAYGO
;add message agent if it isn't there
I '$D(^BDPTCAT("B","MESSAGE AGENT")) D
.S X="MESSAGE AGENT",DIC="^BDPTCAT(",DIC(0)="L",DIADD=1,DLAYGO=90360.3,DIC("DR")=".02///MA;.07///1;.06///0;.08///Y" D FILE^DICN K DIC,DIADD,DLAYGO
.Q
;
;ADD OPTIONS TO BDP
S X=$$ADD^XPDMENU("BDP MENU MANAGER","BDP ADD/EDIT MESSAGE AGENT","MA",5)
S X=$$ADD^XPDMENU("BDP MENU MANAGER","BDP INACT/REACT MESSAGE AGENT","IMA",10)
S X=$$ADD^XPDMENU("BDP MENU DE","BDP ASSIGN MESSAGE AGENT","AMA")
D FHAGE
D ^BJPC2M
S ^AMQQ(1,2,4,1,1)="S X=$S(X=""M"":""MALE"",X=""F"":""FEMALE"",X=""U"":""UNKNOWN"",1:"""")" ;change sex output transform
D PNEU
D MES^XPDUTL($$CJ^XLFSTR("Hold on..I have to do some back-filling of SNOMED codes...",80))
SNO D TOBSMIM ;HEALTH FACTORS FOREVER/IMM ;to background
D URMEAS ;UPDATE/REVIEWED AND MEAS BACK 1 YR ;to background
D NBHEAR ;FOREGROUND
D INFANT ;FOREGROUND ;v infant feeding and exams
T ;BACKFILL 1.01 IN PATIENT REFUSALS
I '$P($G(^APCCCTRL(DUZ(2),99999)),U,1) S DIK="^AUPNPREF(",DIK(1)=".07^ASNMMAP" D ENALL^DIK S $P(^APCCCTRL(DUZ(2),99999),U,1)=1
S X=$O(^APCHSURV("B","OSTEOPOROSIS SCREENING",0))
I X S $P(^APCHSURV(X,0),U,3)=BJPCOS
Q
PNEU ;
;mark Influenza and Pneumovax reminders as Deleted.
S DA=$O(^APCHSURV("B","INFLUENZA",0))
I DA S DIE="^APCHSURV(",DR=".03////D" D ^DIE K DIE,DA,DR
S DA=$O(^APCHSURV("B","PNEUMOVAX",0))
I DA S DIE="^APCHSURV(",DR=".03////D" D ^DIE K DIE,DA,DR
S BJPCX=0 F S BJPCX=$O(^APCHSURV(BJPCX)) Q:BJPCX'=+BJPCX D
.I $P($G(^APCHSURV(BJPCX,0)),U,1)="ANTICOAGULATION: SAFETY MEASURE: URINALYSIS" D
..S DA=BJPCX S DIE="^APCHSURV(",DR=".03////D" D ^DIE K DIE,DA,DR
.I $P($G(^APCHSURV(BJPCX,0)),U,1)="ANTICOAGULATION: SAFETY MEASURE: CBC" D
..S DA=BJPCX S DIE="^APCHSURV(",DR=".03////D" D ^DIE K DIE,DA,DR
.I $P($G(^APCHSURV(BJPCX,0)),U,1)="ANTICOAGULATION: SAFETY MEASURE: FOBT" D
..S DA=BJPCX S DIE="^APCHSURV(",DR=".03////D" D ^DIE K DIE,DA,DR
Q
TOBSMIM ;
;backfill snomed for tobacco categories health factors and v imm
S ZTIO=""
S ZTRTN="TOBSM1^BJPC2PMU",ZTDTH=$$NOW^XLFDT,ZTDESC="BACKFILL V HEALTH FACTORS WITH SNOMED" D ^%ZTLOAD
Q
TOBSM1 ;
S BJPCX=0
F S BJPCX=$O(^AUPNVHF(BJPCX)) Q:BJPCX'=+BJPCX D
.S DA=BJPCX
.D HF^AUPNMAP
.Q
D IMM1
Q
IMM1 ;
S BJPCX=0
F S BJPCX=$O(^AUPNVIMM(BJPCX)) Q:BJPCX'=+BJPCX D
.S DA=BJPCX
.D IMM^AUPNMAP
.Q
Q
NBHEAR ;
S BJPCD=$O(^AUTTEXAM("C",38,0))
S BJPCX=0
F S BJPCX=$O(^AUPNVXAM("B",BJPCD,BJPCX)) Q:BJPCX'=+BJPCX D
.Q:'$D(^AUPNVXAM(BJPCX,0))
.S DA=BJPCX
.D EXAM^AUPNMAP
.Q
S BJPCD=$O(^AUTTEXAM("C",39,0))
S BJPCX=0
F S BJPCX=$O(^AUPNVXAM("B",BJPCD,BJPCX)) Q:BJPCX'=+BJPCX D
.Q:'$D(^AUPNVXAM(BJPCX,0))
.S DA=BJPCX
.D EXAM^AUPNMAP
.Q
Q
INFANT ;
S BJPCD=$$FMADD^XLFDT(DT,(5*366)) ;go back about 5 years
F S BJPCD=$O(^AUPNVSIT("B",BJPCD)) Q:BJPCD="" D
.S BJPCV=0 F S BJPCV=$O(^AUPNVSIT("B",BJPCD,BJPCV)) Q:BJPCV'=+BJPCV D
..S BJPCX=0
..F S BJPCX=$O(^AUPNVIF("AD",BJPCV,BJPCX)) Q:BJPCX'=+BJPCX D
...Q:'$D(^AUPNVIF(BJPCX,0))
...S DA=BJPCX
...D IF^AUPNMAP
...Q
Q
URMEAS ;
;backfill snomed for updated/reviewed/exam and meas for 1 year
S ZTIO=""
S ZTRTN="URMEAS1^BJPC2PMU",ZTDTH=$$NOW^XLFDT,ZTDESC="BACKFILL V UPDATED/MEAS WITH SNOMED" D ^%ZTLOAD
Q
URMEAS1 ;
S BJPCD=$$FMADD^XLFDT(DT,-367) ;go back about a year
F S BJPCD=$O(^AUPNVSIT("B",BJPCD)) Q:BJPCD="" D
.S BJPCV=0 F S BJPCV=$O(^AUPNVSIT("B",BJPCD,BJPCV)) Q:BJPCV'=+BJPCV D
..S BJPCX=0
..F S BJPCX=$O(^AUPNVRUP("AD",BJPCV,BJPCX)) Q:BJPCX'=+BJPCX D
...Q:'$D(^AUPNVRUP(BJPCX,0))
...S DA=BJPCX
...D UPDREV^AUPNMAP
...Q
..S BJPCX=0
..F S BJPCX=$O(^AUPNVMSR("AD",BJPCV,BJPCX)) Q:BJPCX'=+BJPCX D
...Q:'$D(^AUPNVMSR(BJPCX,0))
...S DA=BJPCX
...D MEAS^AUPNMAP
..S BJPCX=0
..F S BJPCX=$O(^AUPNVXAM("AD",BJPCV,BJPCX)) Q:BJPCX'=+BJPCX D
...Q:'$D(^AUPNVXAM(BJPCX,0))
...S DA=BJPCX
...D EXAM^AUPNMAP
Q
FHAGE ;
;move age range to age
D MES^XPDUTL($$CJ^XLFSTR("Moving Family History Age Range to Age field..",IOM))
NEW BJPCX,BJPCA,BJPCV
S BJPCX=0 F S BJPCX=$O(^AUPNFH(BJPCX)) Q:BJPCX'=+BJPCX D
.Q:$P(^AUPNFH(BJPCX,0),U,16) ;already dealt with this entry
.I $P(^AUPNFH(BJPCX,0),U,5)]"" D Q
..S DA=BJPCX,DIE="^AUPNFH(",DR=".11///@;.16///1" D ^DIE K DA,DIE,DR
.Q:$P(^AUPNFH(BJPCX,0),U,11)="" ;no age range
.S BJPCA=$P(^AUPNFH(BJPCX,0),U,11)
.I BJPCA="U" D Q
..S DA=BJPCX,DIE="^AUPNFH(",DR=".11///@;.16///1" D ^DIE K DA,DIE,DR
.S BJPCV=$S(BJPCA=2:20,BJPCA=3:30,BJPCA=4:40,BJPCA=5:50,BJPCA=6:60,BJPCA=1:10,BJPCA="I":1)
.S DA=BJPCX,DIE="^AUPNFH(",DR=".15///1;.16///1;.05///"_BJPCV D ^DIE K DA,DIE,DR
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
BJPC2PMU ; IHS/CMI/LAB - PCC Suite v2.0 patch 10 environment check ;
+1 ;;2.0;IHS PCC SUITE;**10**;MAY 14, 2009;Build 88
+2 ;
+3 ;
+4 ; The following line prevents the "Disable Options..." and "Move Routines..." questions from being asked during the install.
+5 IF $GET(XPDENV)=1
SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
+6 FOR X="XPO1","XPZ1","XPZ2","XPI1"
SET XPDDIQ(X)=0
+7 ;KERNEL
+8 IF +$$VERSION^XPDUTL("XU")<8
DO MES^XPDUTL($$CJ^XLFSTR("Version 8.0 of KERNEL is required. Not installed",80))
DO SORRY(2)
IF 1
+9 IF '$TEST
DO MES^XPDUTL($$CJ^XLFSTR("Requires Kernel Version 8.0....Present.",80))
+10 ;FILEMAN
+11 IF +$$VERSION^XPDUTL("DI")<22
DO MES^XPDUTL($$CJ^XLFSTR("Version 22.0 of FILEMAN is required. Not installed.",80))
DO SORRY(2)
IF 1
+12 IF '$TEST
DO MES^XPDUTL($$CJ^XLFSTR("Requires Fileman v22....Present.",80))
+13 ;BJPC
+14 IF $$VERSION^XPDUTL("BJPC")'="2.0"
DO MES^XPDUTL($$CJ^XLFSTR("Version 2.0 of the IHS PCC SUITE (BJPC) is required. Not installed",80))
DO SORRY(2)
IF 1
+15 IF '$TEST
DO MES^XPDUTL($$CJ^XLFSTR("Requires IHS PCC Suite (BJPC) Version 2.0....Present.",80))
+16 IF '$$INSTALLD("BJPC*2.0*8")
DO SORRY(2)
+17 IF '$$INSTALLD("BJPC*2.0*9")
DO SORRY(2)
+18 IF '$$INSTALLD("AVA*93.2*22")
DO SORRY(2)
+19 IF '$$INSTALLD("AUT*98.1*26")
DO SORRY(2)
+20 IF '$$INSTALLD("AUPN*99.1*23")
DO SORRY(2)
+21 IF '$$INSTALLD("AUM*13.0*2")
DO SORRY(2)
+22 IF '$$INSTALLD("AUM*13.0*3")
DO SORRY(2)
+23 IF +$$VERSION^XPDUTL("BCQM")<1
DO MES^XPDUTL($$CJ^XLFSTR("Version 1.0 of BCQM - IHS CODE MAPPING is required. Not installed",80))
DO SORRY(2)
IF 1
+24 IF '$TEST
DO MES^XPDUTL($$CJ^XLFSTR("Requires BCQM V1.0....Present.",80))
+25 IF +$$VERSION^XPDUTL("BSTS")<1
DO MES^XPDUTL($$CJ^XLFSTR("Version 1.0 of BSTS - IHS TERMINOLOGY is required. Not installed",80))
DO SORRY(2)
IF 1
+26 IF '$TEST
DO MES^XPDUTL($$CJ^XLFSTR("Requires BSTS V1.0....Present.",80))
+27 IF '$$INSTALLD("AG*7.1*11")
DO SORRY(2)
+28 QUIT
PRE ;
+1 ;get rid of v care planning
+2 SET DIU=9000010.57
SET DIU(0)="DET"
DO EN^DIU2
KILL DIU
+3 SET DIU=9000010.59
SET DIU(0)="E"
DO EN^DIU2
KILL DIU
+4 SET DIU=9000010.61
SET DIU(0)="E"
DO EN^DIU2
KILL DIU
+5 SET DIU=9000010.63
SET DIU(0)="E"
DO EN^DIU2
KILL DIU
+6 SET DA=$ORDER(^AUTTREFR("B","410561003",0))
+7 IF DA
SET DIE="^AUTTREFR("
SET DR=".01///410534003"
DO ^DIE
KILL DA,DR,DIE
+8 SET BJPCOS=$ORDER(^APCHSURV("B","OSTEOPOROSIS SCREENING",0))
+9 IF BJPCOS
SET BJPCOS=$PIECE(^APCHSURV(BJPCOS,0),U,3)
+10 ;FIX 2101 MULTIPLE IN REPRODUCTIVE FACTORS
+11 SET DA=0
FOR
SET DA=$ORDER(^AUPNREP(DA))
IF DA'=+DA
QUIT
Begin DoDot:1
+12 IF '$DATA(^AUPNREP(DA,2101,0))
QUIT
+13 IF $PIECE(^AUPNREP(DA,2101,0),U,2)="S"
SET $PIECE(^AUPNREP(DA,2101,0),U,2)="9000017.0201PA"
End DoDot:1
+14 QUIT
+15 ;
POST ;
+1 ;add refusal type SNOMED to refusal type file
+2 IF '$DATA(^AUTTREFT("B","SNOMED"))
Begin DoDot:1
+3 KILL DIC,DR,D0,DO
+4 SET X="SNOMED"
SET DIC="^AUTTREFT("
SET DIC("DR")=".02////9002318.4;.03////1"
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9999999.73
DO FILE^DICN
KILL DIC,DIADD,DLAYGO
End DoDot:1
+5 ;add message agent if it isn't there
+6 IF '$DATA(^BDPTCAT("B","MESSAGE AGENT"))
Begin DoDot:1
+7 SET X="MESSAGE AGENT"
SET DIC="^BDPTCAT("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=90360.3
SET DIC("DR")=".02///MA;.07///1;.06///0;.08///Y"
DO FILE^DICN
KILL DIC,DIADD,DLAYGO
+8 QUIT
End DoDot:1
+9 ;
+10 ;ADD OPTIONS TO BDP
+11 SET X=$$ADD^XPDMENU("BDP MENU MANAGER","BDP ADD/EDIT MESSAGE AGENT","MA",5)
+12 SET X=$$ADD^XPDMENU("BDP MENU MANAGER","BDP INACT/REACT MESSAGE AGENT","IMA",10)
+13 SET X=$$ADD^XPDMENU("BDP MENU DE","BDP ASSIGN MESSAGE AGENT","AMA")
+14 DO FHAGE
+15 DO ^BJPC2M
+16 ;change sex output transform
SET ^AMQQ(1,2,4,1,1)="S X=$S(X=""M"":""MALE"",X=""F"":""FEMALE"",X=""U"":""UNKNOWN"",1:"""")"
+17 DO PNEU
+18 DO MES^XPDUTL($$CJ^XLFSTR("Hold on..I have to do some back-filling of SNOMED codes...",80))
SNO ;HEALTH FACTORS FOREVER/IMM ;to background
DO TOBSMIM
+1 ;UPDATE/REVIEWED AND MEAS BACK 1 YR ;to background
DO URMEAS
+2 ;FOREGROUND
DO NBHEAR
+3 ;FOREGROUND ;v infant feeding and exams
DO INFANT
T ;BACKFILL 1.01 IN PATIENT REFUSALS
+1 IF '$PIECE($GET(^APCCCTRL(DUZ(2),99999)),U,1)
SET DIK="^AUPNPREF("
SET DIK(1)=".07^ASNMMAP"
DO ENALL^DIK
SET $PIECE(^APCCCTRL(DUZ(2),99999),U,1)=1
+2 SET X=$ORDER(^APCHSURV("B","OSTEOPOROSIS SCREENING",0))
+3 IF X
SET $PIECE(^APCHSURV(X,0),U,3)=BJPCOS
+4 QUIT
PNEU ;
+1 ;mark Influenza and Pneumovax reminders as Deleted.
+2 SET DA=$ORDER(^APCHSURV("B","INFLUENZA",0))
+3 IF DA
SET DIE="^APCHSURV("
SET DR=".03////D"
DO ^DIE
KILL DIE,DA,DR
+4 SET DA=$ORDER(^APCHSURV("B","PNEUMOVAX",0))
+5 IF DA
SET DIE="^APCHSURV("
SET DR=".03////D"
DO ^DIE
KILL DIE,DA,DR
+6 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^APCHSURV(BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:1
+7 IF $PIECE($GET(^APCHSURV(BJPCX,0)),U,1)="ANTICOAGULATION: SAFETY MEASURE: URINALYSIS"
Begin DoDot:2
+8 SET DA=BJPCX
SET DIE="^APCHSURV("
SET DR=".03////D"
DO ^DIE
KILL DIE,DA,DR
End DoDot:2
+9 IF $PIECE($GET(^APCHSURV(BJPCX,0)),U,1)="ANTICOAGULATION: SAFETY MEASURE: CBC"
Begin DoDot:2
+10 SET DA=BJPCX
SET DIE="^APCHSURV("
SET DR=".03////D"
DO ^DIE
KILL DIE,DA,DR
End DoDot:2
+11 IF $PIECE($GET(^APCHSURV(BJPCX,0)),U,1)="ANTICOAGULATION: SAFETY MEASURE: FOBT"
Begin DoDot:2
+12 SET DA=BJPCX
SET DIE="^APCHSURV("
SET DR=".03////D"
DO ^DIE
KILL DIE,DA,DR
End DoDot:2
End DoDot:1
+13 QUIT
TOBSMIM ;
+1 ;backfill snomed for tobacco categories health factors and v imm
+2 SET ZTIO=""
+3 SET ZTRTN="TOBSM1^BJPC2PMU"
SET ZTDTH=$$NOW^XLFDT
SET ZTDESC="BACKFILL V HEALTH FACTORS WITH SNOMED"
DO ^%ZTLOAD
+4 QUIT
TOBSM1 ;
+1 SET BJPCX=0
+2 FOR
SET BJPCX=$ORDER(^AUPNVHF(BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:1
+3 SET DA=BJPCX
+4 DO HF^AUPNMAP
+5 QUIT
End DoDot:1
+6 DO IMM1
+7 QUIT
IMM1 ;
+1 SET BJPCX=0
+2 FOR
SET BJPCX=$ORDER(^AUPNVIMM(BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:1
+3 SET DA=BJPCX
+4 DO IMM^AUPNMAP
+5 QUIT
End DoDot:1
+6 QUIT
NBHEAR ;
+1 SET BJPCD=$ORDER(^AUTTEXAM("C",38,0))
+2 SET BJPCX=0
+3 FOR
SET BJPCX=$ORDER(^AUPNVXAM("B",BJPCD,BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:1
+4 IF '$DATA(^AUPNVXAM(BJPCX,0))
QUIT
+5 SET DA=BJPCX
+6 DO EXAM^AUPNMAP
+7 QUIT
End DoDot:1
+8 SET BJPCD=$ORDER(^AUTTEXAM("C",39,0))
+9 SET BJPCX=0
+10 FOR
SET BJPCX=$ORDER(^AUPNVXAM("B",BJPCD,BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:1
+11 IF '$DATA(^AUPNVXAM(BJPCX,0))
QUIT
+12 SET DA=BJPCX
+13 DO EXAM^AUPNMAP
+14 QUIT
End DoDot:1
+15 QUIT
INFANT ;
+1 ;go back about 5 years
SET BJPCD=$$FMADD^XLFDT(DT,(5*366))
+2 FOR
SET BJPCD=$ORDER(^AUPNVSIT("B",BJPCD))
IF BJPCD=""
QUIT
Begin DoDot:1
+3 SET BJPCV=0
FOR
SET BJPCV=$ORDER(^AUPNVSIT("B",BJPCD,BJPCV))
IF BJPCV'=+BJPCV
QUIT
Begin DoDot:2
+4 SET BJPCX=0
+5 FOR
SET BJPCX=$ORDER(^AUPNVIF("AD",BJPCV,BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:3
+6 IF '$DATA(^AUPNVIF(BJPCX,0))
QUIT
+7 SET DA=BJPCX
+8 DO IF^AUPNMAP
+9 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
URMEAS ;
+1 ;backfill snomed for updated/reviewed/exam and meas for 1 year
+2 SET ZTIO=""
+3 SET ZTRTN="URMEAS1^BJPC2PMU"
SET ZTDTH=$$NOW^XLFDT
SET ZTDESC="BACKFILL V UPDATED/MEAS WITH SNOMED"
DO ^%ZTLOAD
+4 QUIT
URMEAS1 ;
+1 ;go back about a year
SET BJPCD=$$FMADD^XLFDT(DT,-367)
+2 FOR
SET BJPCD=$ORDER(^AUPNVSIT("B",BJPCD))
IF BJPCD=""
QUIT
Begin DoDot:1
+3 SET BJPCV=0
FOR
SET BJPCV=$ORDER(^AUPNVSIT("B",BJPCD,BJPCV))
IF BJPCV'=+BJPCV
QUIT
Begin DoDot:2
+4 SET BJPCX=0
+5 FOR
SET BJPCX=$ORDER(^AUPNVRUP("AD",BJPCV,BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:3
+6 IF '$DATA(^AUPNVRUP(BJPCX,0))
QUIT
+7 SET DA=BJPCX
+8 DO UPDREV^AUPNMAP
+9 QUIT
End DoDot:3
+10 SET BJPCX=0
+11 FOR
SET BJPCX=$ORDER(^AUPNVMSR("AD",BJPCV,BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:3
+12 IF '$DATA(^AUPNVMSR(BJPCX,0))
QUIT
+13 SET DA=BJPCX
+14 DO MEAS^AUPNMAP
End DoDot:3
+15 SET BJPCX=0
+16 FOR
SET BJPCX=$ORDER(^AUPNVXAM("AD",BJPCV,BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:3
+17 IF '$DATA(^AUPNVXAM(BJPCX,0))
QUIT
+18 SET DA=BJPCX
+19 DO EXAM^AUPNMAP
End DoDot:3
End DoDot:2
End DoDot:1
+20 QUIT
FHAGE ;
+1 ;move age range to age
+2 DO MES^XPDUTL($$CJ^XLFSTR("Moving Family History Age Range to Age field..",IOM))
+3 NEW BJPCX,BJPCA,BJPCV
+4 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUPNFH(BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:1
+5 ;already dealt with this entry
IF $PIECE(^AUPNFH(BJPCX,0),U,16)
QUIT
+6 IF $PIECE(^AUPNFH(BJPCX,0),U,5)]""
Begin DoDot:2
+7 SET DA=BJPCX
SET DIE="^AUPNFH("
SET DR=".11///@;.16///1"
DO ^DIE
KILL DA,DIE,DR
End DoDot:2
QUIT
+8 ;no age range
IF $PIECE(^AUPNFH(BJPCX,0),U,11)=""
QUIT
+9 SET BJPCA=$PIECE(^AUPNFH(BJPCX,0),U,11)
+10 IF BJPCA="U"
Begin DoDot:2
+11 SET DA=BJPCX
SET DIE="^AUPNFH("
SET DR=".11///@;.16///1"
DO ^DIE
KILL DA,DIE,DR
End DoDot:2
QUIT
+12 SET BJPCV=$SELECT(BJPCA=2:20,BJPCA=3:30,BJPCA=4:40,BJPCA=5:50,BJPCA=6:60,BJPCA=1:10,BJPCA="I":1)
+13 SET DA=BJPCX
SET DIE="^AUPNFH("
SET DR=".15///1;.16///1;.05///"_BJPCV
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+14 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
