BGOIN019 ; IHS/MSC/PLS - BGO*1.1*19 ;07-Mar-2016 12:06;PLS
;;1.1;BGO COMPONENTS;**19**;Mar 20, 2007
EC Q
; Preinit
PRE ;
Q
; Postinit
POST ;
; Register RPCs
D REGNMSP^CIAURPC("BGO","CIAV VUECENTRIC")
; Update BGO component versions
N VER,FDA,PID,IEN,X
D BMES^XPDUTL("Updating version numbers...")
F VER=0:1 S X=$P($T(VER+VER),";;",2) Q:'$L(X) D
.S PID=$$PRGID^CIAVMCFG($P(X,";"))
.S:PID FDA(19930.2,PID_",",2)=$P(X,";",2),FDA(19930.2,PID_",",7)=$P(X,";",3)
D:$D(FDA) FILE^DIE(,"FDA")
D UPDCHM
D PARS2
Q
;
UPDCHM ;EP-
N CHM,PID
F CHM=0:1 S X=$P($T(CHM+CHM),";;",2) Q:'$L(X) D
.S PID=$$PRGID^CIAVMCFG($P(X,";"))
.D AECHM(PID,$P(X,";",2,99))
W !!
Q
UPDBUSA ;EP-
N RPC,RPCIEN,FDA,VAL
S VAL="S X=$P(X,U)"
F RPC=0:1 S X=$P($T(BUSARPC+RPC),";;",2) Q:'$L(X) D
.S RPCIEN=$$FIND1^DIC(9002319.03,"","MX",X)
.Q:'RPCIEN
.S FDA(9002319.03,RPCIEN_",",2.02)=VAL
I $D(FDA) D
.D FILE^DIE(,"FDA")
Q
PARS ;Store system levels of new parameter
D EN^XPAR("SYS","BGO PROBLEM EDUCATION",1,"DISEASE PROCESS")
D EN^XPAR("SYS","BGO PROBLEM EDUCATION",2,"NUTRITION")
D EN^XPAR("SYS","BGO PROBLEM EDUCATION",3,"EXERCISE")
D EN^XPAR("SYS","BGO PROBLEM EDUCATION",4,"LIFESTYLE ADAPTATION")
D EN^XPAR("SYS","BGO PROBLEM EDUCATION",5,"MEDICATIONS")
D EN^XPAR("SYS","BGO PROBLEM EDUCATION",6,"PREVENTION")
Q
PARS1 ;EP - Cleanup old parameter values for location
N PAR,ENT,ERR
S PAR="" S PAR=$O(^XTV(8989.51,"B","BGO PROBLEM EDUCATION",PAR))
Q:'+PAR
S ENT="" F S ENT=$O(^XTV(8989.5,"AC",PAR,ENT)) Q:ENT="" D
.Q:$P(ENT,";",2)'="SC("
.S ERR=0
.D NDEL^XPAR(ENT,PAR,.ERR)
N LIEN
S LIEN="" S LIEN=$O(^XTV(8989.51,PAR,30,"B",100,LIEN))
Q:LIEN=""
S DA(1)=PAR,DA=LIEN
S DIK="^XTV(8989.51,PAR,30,"
D ^DIK
Q
PARS2 ;EP - Populate SNOMED Parameters
D LOCK("BGO NORMAL/ABNORMAL",0)
D EN^XPAR("SYS","BGO NORMAL/ABNORMAL",1,"w/o abn find;Without Abnormal Findings;162656002")
D EN^XPAR("SYS","BGO NORMAL/ABNORMAL",2,"w/abn find;With Abnormal Findings;71994000")
D EN^XPAR("SYS","BGO NORMAL/ABNORMAL",3,"not examined/unk;Not Applicable/Not Examined/Unknown")
D LOCK("BGO NORMAL/ABNORMAL",1)
Q
;Set prohibit editing field of parameter
LOCK(PARAM,VAL) ;EP-
N IEN
S IEN=$O(^XTV(8989.51,"B",PARAM,0))
Q:'IEN
S $P(^XTV(8989.51,IEN,0),U,6)=VAL
Q
; Set DISABLED field of OBJ to VAL
DISABLED(OBJ,VAL) ;
N PID,FDA
S VAL=$G(VAL,0)
S PID=$$PRGID^CIAVMCFG($G(OBJ))
Q:'PID
S FDA(19930.2,PID_",",13)=VAL
D FILE^DIE(,"FDA")
Q
PICK ;Install the national pick lists
D UPDATE^BGOSNLK
Q
N LP,NAME,SNO,BSTS,RET
F LP=0:1 S NAME=$P($T(LIST+LP),";;",2) Q:'$L(NAME) D
.S BSTS=$P(NAME,"^",1)
.S SNO=$P(NAME,"^",2)
.D IMPORT^BGOSNLK(.RET,BSTS,SNO)
Q
;National pick lists
LIST ;;PICK ABNORMAL FINDINGS^ABNORMAL FINDINGS
;;PICK CQM Problems^CQM PROBLEMS
;;PICK Case Management^CASE MANAGEMENT
;;PICK Diabetic Retinopathy^DIABETIC RETINOPATHY
;;PICK Eye General^EYE GENERAL
;;PICK Immunizations^IMMUNIZATIONS
;;PICK NIST Problems^NIST PROBLEMS
;;PICK Nutrition^NUTRITION
;;PICK Prenatal - Care^PRENATAL CARE
;;PICK Prenatal - Problem Fetus^PRENATAL PROBLEM FETUS
;;PICK Prenatal - Problem Pregnancy^PRENATAL PROBLEM PREGNANCY
;;PICK Prenatal - Risk^PRENATAL RISK
;;PICK Public Health Nursing^PUBLIC HEALTH NURSING
;;PICK Womens Health^WOMENS HEALTH
;;
AECHM(PID,VAL) ;EP-
N LN,FN,IDX,TXT,ARY,CNT,IENS
S FN=$P(VAL,";"),CNT=0
S LN=0 F S LN=$O(^CIAVOBJ(19930.2,PID,6,LN)) Q:'LN D Q:$G(IDX)
.S TXT=^CIAVOBJ(19930.2,PID,6,LN,0)
.S ARY(LN,0)=TXT,CNT=CNT+1
.I $$UP^XLFSTR(TXT)[$$UP^XLFSTR($P(VAL,";")) S IDX=LN
I $G(IDX) D
.S ^CIAVOBJ(19930.2,PID,6,IDX,0)=VAL
E D
.S ARY($S('CNT:1,1:CNT+1),0)=VAL
.S IENS=PID_","
.S FDA(19930.2,IENS,10)="ARY"
.D FILE^DIE(,"FDA")
Q
;
CLNMNU ;
; Remove option from menu
N OPTION,MENU,DA,DIK,PAR,ERR,X
S (OPTION,MENU)=""
S OPTION="BGO IMM STOP ADDING CPT CODES"
S MENU="BGOIMM MAIN"
S X=$$DELETE^XPDMENU(MENU,OPTION)
Q:'+X
;Inactivate the option
D OUT^XPDMENU(OPTION,"No longer used")
;Clean out the parameter
S PAR=""
S PAR=$O(^XTV(8989.51,"B","BGO IMM STOP ADDING CPT CODES",PAR))
Q:'+PAR
S ERR=0
D NDEL^XPAR("USR",PAR,.ERR)
Q:ERR>0
D NDEL^XPAR("DIV",PAR,.ERR)
Q:ERR>0
D NDEL^XPAR("PKG",PAR,.ERR)
Q:ERR>0
;Delete the parameter
S DA=PAR,DIK="^XTV(8989.51," D ^DIK
Q
VER ;;BEHIPL.IPL;1.1.0.21669;AB79172EC1F4E38A5E5C735DEA58254C
;;
CHM ;;
;;
BUSARPC ;;
;;
BGOIN019 ; IHS/MSC/PLS - BGO*1.1*19 ;07-Mar-2016 12:06;PLS
+1 ;;1.1;BGO COMPONENTS;**19**;Mar 20, 2007
EC QUIT
+1 ; Preinit
PRE ;
+1 QUIT
+2 ; Postinit
POST ;
+1 ; Register RPCs
+2 DO REGNMSP^CIAURPC("BGO","CIAV VUECENTRIC")
+3 ; Update BGO component versions
+4 NEW VER,FDA,PID,IEN,X
+5 DO BMES^XPDUTL("Updating version numbers...")
+6 FOR VER=0:1
SET X=$PIECE($TEXT(VER+VER),";;",2)
IF '$LENGTH(X)
QUIT
Begin DoDot:1
+7 SET PID=$$PRGID^CIAVMCFG($PIECE(X,";"))
+8 IF PID
SET FDA(19930.2,PID_",",2)=$PIECE(X,";",2)
SET FDA(19930.2,PID_",",7)=$PIECE(X,";",3)
End DoDot:1
+9 IF $DATA(FDA)
DO FILE^DIE(,"FDA")
+10 DO UPDCHM
+11 DO PARS2
+12 QUIT
+13 ;
UPDCHM ;EP-
+1 NEW CHM,PID
+2 FOR CHM=0:1
SET X=$PIECE($TEXT(CHM+CHM),";;",2)
IF '$LENGTH(X)
QUIT
Begin DoDot:1
+3 SET PID=$$PRGID^CIAVMCFG($PIECE(X,";"))
+4 DO AECHM(PID,$PIECE(X,";",2,99))
End DoDot:1
+5 WRITE !!
+6 QUIT
UPDBUSA ;EP-
+1 NEW RPC,RPCIEN,FDA,VAL
+2 SET VAL="S X=$P(X,U)"
+3 FOR RPC=0:1
SET X=$PIECE($TEXT(BUSARPC+RPC),";;",2)
IF '$LENGTH(X)
QUIT
Begin DoDot:1
+4 SET RPCIEN=$$FIND1^DIC(9002319.03,"","MX",X)
+5 IF 'RPCIEN
QUIT
+6 SET FDA(9002319.03,RPCIEN_",",2.02)=VAL
End DoDot:1
+7 IF $DATA(FDA)
Begin DoDot:1
+8 DO FILE^DIE(,"FDA")
End DoDot:1
+9 QUIT
PARS ;Store system levels of new parameter
+1 DO EN^XPAR("SYS","BGO PROBLEM EDUCATION",1,"DISEASE PROCESS")
+2 DO EN^XPAR("SYS","BGO PROBLEM EDUCATION",2,"NUTRITION")
+3 DO EN^XPAR("SYS","BGO PROBLEM EDUCATION",3,"EXERCISE")
+4 DO EN^XPAR("SYS","BGO PROBLEM EDUCATION",4,"LIFESTYLE ADAPTATION")
+5 DO EN^XPAR("SYS","BGO PROBLEM EDUCATION",5,"MEDICATIONS")
+6 DO EN^XPAR("SYS","BGO PROBLEM EDUCATION",6,"PREVENTION")
+7 QUIT
PARS1 ;EP - Cleanup old parameter values for location
+1 NEW PAR,ENT,ERR
+2 SET PAR=""
SET PAR=$ORDER(^XTV(8989.51,"B","BGO PROBLEM EDUCATION",PAR))
+3 IF '+PAR
QUIT
+4 SET ENT=""
FOR
SET ENT=$ORDER(^XTV(8989.5,"AC",PAR,ENT))
IF ENT=""
QUIT
Begin DoDot:1
+5 IF $PIECE(ENT,";",2)'="SC("
QUIT
+6 SET ERR=0
+7 DO NDEL^XPAR(ENT,PAR,.ERR)
End DoDot:1
+8 NEW LIEN
+9 SET LIEN=""
SET LIEN=$ORDER(^XTV(8989.51,PAR,30,"B",100,LIEN))
+10 IF LIEN=""
QUIT
+11 SET DA(1)=PAR
SET DA=LIEN
+12 SET DIK="^XTV(8989.51,PAR,30,"
+13 DO ^DIK
+14 QUIT
PARS2 ;EP - Populate SNOMED Parameters
+1 DO LOCK("BGO NORMAL/ABNORMAL",0)
+2 DO EN^XPAR("SYS","BGO NORMAL/ABNORMAL",1,"w/o abn find;Without Abnormal Findings;162656002")
+3 DO EN^XPAR("SYS","BGO NORMAL/ABNORMAL",2,"w/abn find;With Abnormal Findings;71994000")
+4 DO EN^XPAR("SYS","BGO NORMAL/ABNORMAL",3,"not examined/unk;Not Applicable/Not Examined/Unknown")
+5 DO LOCK("BGO NORMAL/ABNORMAL",1)
+6 QUIT
+7 ;Set prohibit editing field of parameter
LOCK(PARAM,VAL) ;EP-
+1 NEW IEN
+2 SET IEN=$ORDER(^XTV(8989.51,"B",PARAM,0))
+3 IF 'IEN
QUIT
+4 SET $PIECE(^XTV(8989.51,IEN,0),U,6)=VAL
+5 QUIT
+6 ; Set DISABLED field of OBJ to VAL
DISABLED(OBJ,VAL) ;
+1 NEW PID,FDA
+2 SET VAL=$GET(VAL,0)
+3 SET PID=$$PRGID^CIAVMCFG($GET(OBJ))
+4 IF 'PID
QUIT
+5 SET FDA(19930.2,PID_",",13)=VAL
+6 DO FILE^DIE(,"FDA")
+7 QUIT
PICK ;Install the national pick lists
+1 DO UPDATE^BGOSNLK
+2 QUIT
+3 NEW LP,NAME,SNO,BSTS,RET
+4 FOR LP=0:1
SET NAME=$PIECE($TEXT(LIST+LP),";;",2)
IF '$LENGTH(NAME)
QUIT
Begin DoDot:1
+5 SET BSTS=$PIECE(NAME,"^",1)
+6 SET SNO=$PIECE(NAME,"^",2)
+7 DO IMPORT^BGOSNLK(.RET,BSTS,SNO)
End DoDot:1
+8 QUIT
+9 ;National pick lists
LIST ;;PICK ABNORMAL FINDINGS^ABNORMAL FINDINGS
+1 ;;PICK CQM Problems^CQM PROBLEMS
+2 ;;PICK Case Management^CASE MANAGEMENT
+3 ;;PICK Diabetic Retinopathy^DIABETIC RETINOPATHY
+4 ;;PICK Eye General^EYE GENERAL
+5 ;;PICK Immunizations^IMMUNIZATIONS
+6 ;;PICK NIST Problems^NIST PROBLEMS
+7 ;;PICK Nutrition^NUTRITION
+8 ;;PICK Prenatal - Care^PRENATAL CARE
+9 ;;PICK Prenatal - Problem Fetus^PRENATAL PROBLEM FETUS
+10 ;;PICK Prenatal - Problem Pregnancy^PRENATAL PROBLEM PREGNANCY
+11 ;;PICK Prenatal - Risk^PRENATAL RISK
+12 ;;PICK Public Health Nursing^PUBLIC HEALTH NURSING
+13 ;;PICK Womens Health^WOMENS HEALTH
+14 ;;
AECHM(PID,VAL) ;EP-
+1 NEW LN,FN,IDX,TXT,ARY,CNT,IENS
+2 SET FN=$PIECE(VAL,";")
SET CNT=0
+3 SET LN=0
FOR
SET LN=$ORDER(^CIAVOBJ(19930.2,PID,6,LN))
IF 'LN
QUIT
Begin DoDot:1
+4 SET TXT=^CIAVOBJ(19930.2,PID,6,LN,0)
+5 SET ARY(LN,0)=TXT
SET CNT=CNT+1
+6 IF $$UP^XLFSTR(TXT)[$$UP^XLFSTR($PIECE(VAL,";"))
SET IDX=LN
End DoDot:1
IF $GET(IDX)
QUIT
+7 IF $GET(IDX)
Begin DoDot:1
+8 SET ^CIAVOBJ(19930.2,PID,6,IDX,0)=VAL
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 SET ARY($SELECT('CNT:1,1:CNT+1),0)=VAL
+11 SET IENS=PID_","
+12 SET FDA(19930.2,IENS,10)="ARY"
+13 DO FILE^DIE(,"FDA")
End DoDot:1
+14 QUIT
+15 ;
CLNMNU ;
+1 ; Remove option from menu
+2 NEW OPTION,MENU,DA,DIK,PAR,ERR,X
+3 SET (OPTION,MENU)=""
+4 SET OPTION="BGO IMM STOP ADDING CPT CODES"
+5 SET MENU="BGOIMM MAIN"
+6 SET X=$$DELETE^XPDMENU(MENU,OPTION)
+7 IF '+X
QUIT
+8 ;Inactivate the option
+9 DO OUT^XPDMENU(OPTION,"No longer used")
+10 ;Clean out the parameter
+11 SET PAR=""
+12 SET PAR=$ORDER(^XTV(8989.51,"B","BGO IMM STOP ADDING CPT CODES",PAR))
+13 IF '+PAR
QUIT
+14 SET ERR=0
+15 DO NDEL^XPAR("USR",PAR,.ERR)
+16 IF ERR>0
QUIT
+17 DO NDEL^XPAR("DIV",PAR,.ERR)
+18 IF ERR>0
QUIT
+19 DO NDEL^XPAR("PKG",PAR,.ERR)
+20 IF ERR>0
QUIT
+21 ;Delete the parameter
+22 SET DA=PAR
SET DIK="^XTV(8989.51,"
DO ^DIK
+23 QUIT
VER ;;BEHIPL.IPL;1.1.0.21669;AB79172EC1F4E38A5E5C735DEA58254C
+1 ;;
CHM ;;
+1 ;;
BUSARPC ;;
+1 ;;
