- 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