BGOSNLK ; IHS/MSC/MGH - SNOMED Picklists ;05-Dec-2014 07:22;du
;;1.1;BGO COMPONENTS;**13,14**;Mar 20, 2007;Build 1
;Input is the name of the picklist
GETLST(RET,INP) ;Return items from a SNOMED picklist
N FNUM,GRP,PICK,ITM,SNO,DESC,TXT,STAT,CNT,IN,OUT,X,DATA,ICD
S RET=$$TMPGBL^BGOUTL
S CNT=0
S FNUM=90362.34
S PICK="" S PICK=$O(^BGOSNOPR("B",INP,PICK))
Q:PICK=""
S ITM=0 F S ITM=$O(^BGOSNOPR(PICK,1,ITM)) Q:'+ITM D
.S DATA=$G(^BGOSNOPR(PICK,1,ITM,0))
.S SNO=$P(DATA,U,1)
.S DESC=$P(DATA,U,2)
.S STAT=$P(DATA,U,6)
.S ICD=""
.S GRP=$P($G(^BGOSNOPR(PICK,1,ITM,1)),U,2)
.;look it up in Apelon
.;changed to use new API
.;S X=$$CONC^BSTSAPI(SNO_"^36^^1")
.S X=$$CONC^AUPNSICD(SNO_"^^^1")
.I $P(X,U,1)'="" D
..S DESC=$P(X,U,3)
..S TXT=$P(X,U,4)
..S ICD=$P(X,U,5)
.S CNT=CNT+1
.S @RET@(CNT)=TXT_U_DESC_U_SNO_U_ICD_U_STAT_U_GRP
Q
SUBSET(RET,INP) ;Return data from a subset
N CNT,SUBSET,IN,OUT,X,SNO,ICD,DESC,TXT
S CNT=0
I $G(RET)="" S RET=$$TMPGBL^BGOUTL
;look it up in Apelon
S OUT=$$SNOTMP
S IN=INP_"^^1"
S X=$$SUBLST^BSTSAPI(.OUT,.IN)
;1 means success
I X>0 D
.S CNT="" F S CNT=$O(@OUT@(CNT)) Q:CNT="" D
..S ICD=""
..S NODE=$G(@OUT@(CNT))
..S SNO=$P(NODE,U,1)
..;IHS/MSC/MGH changed to use new api
..;S X=$$CONC^BSTSAPI(SNO_"^36^^1")
..S X=$$CONC^AUPNSICD(SNO_"^^^1")
..I X'="" S ICD=$P($P(X,U,5),";",1)
..S DESC=$P(NODE,U,2),TXT=$P(NODE,U,3)
..S @RET@(CNT)=TXT_U_DESC_U_SNO_U_ICD_U_""_U_TXT
Q
SNOTMP() K ^TMP("BGOSN"_$G(X),$J) Q $NA(^($J))
;
UPDATE() ;Update picklists from Apelon
N X,ARR,I,RET
S X=$$SUBSET^BSTSAPI("ARR")
S I=0 F S I=$O(ARR(I)) Q:I="" D
.S NAME=$G(ARR(I))
.I $E(NAME,1,4)="PICK" D
..S IEN="" S IEN=$O(^BGOSNOPR("SS",$E(NAME,1,30),IEN))
..I IEN="" D
...S PICK=$E(NAME,6,$L(NAME))
...;S PICK=$$UPPER(PICK)
...S IEN=$$NEW(NAME,PICK)
..Q:IEN=""
..S PICK=$P($G(^BGOSNOPR(IEN,0)),U,1)
..W !,"Updating "_PICK
..D IMPORT(.RET,NAME,PICK)
..I $$UPPER($E(PICK,1,8))="PRENATAL" D
...N IENS,FDA,ERR
...S IENS=IEN_","
...S FDA(90362.34,IENS,.09)=1
...D UPDATE^DIE(,"FDA","","ERR")
..S INP=IEN_U_DUZ_U_1
..D SETMGR^BGOSNOPR(.RET,INP)
Q
;Import data from an Apelon subset to a SNOMED picklist
;Input parameters
;1)The Apelon subset
;2)The name of the SNOMED picklist
IMPORT(RET,SUBSET,INP) ;EP
N PICK,OUT,IN,X,NODE,CK,SNO,AIEN,FNUM,FDA,IEN,ERR,NEW
S NEW=0
S PICK="" S PICK=$O(^BGOSNOPR("B",INP,PICK))
I PICK="" S NEW=1 S PICK=$$NEW(SUBSET,INP)
Q:PICK<1
S OUT=$$SNOTMP
S IN=SUBSET
S X=$$SUBLST^BSTSAPI(.OUT,.IN)
;1 means success
I X>0 D
.S CNT="" F S CNT=$O(@OUT@(CNT)) Q:CNT="" D
..S NODE=$G(@OUT@(CNT))
..S SNO=$P(NODE,U,1)
..;Don't load again if its already there
..S CK=$O(^BGOSNOPR(PICK,1,"B",SNO,""))
..Q:+CK
..N FDA,IEN,ERR
..S AIEN="+1,"_PICK_","
..S FDA(90362.342,AIEN,.01)=SNO
..S FDA(90362.342,AIEN,.02)=$P(NODE,U,2)
..S FDA(90362.342,AIEN,.03)=0
..S FDA(90362.342,AIEN,6)=$P(NODE,U,3)
..D UPDATE^DIE(,"FDA","IEN","ERR")
..I '$D(ERR) S RET=IEN(1)
..E S RET=RET_"-1^Error adding item"_SNO
.S INP=PICK_U_DUZ_U_1
.D SETMGR^BGOSNOPR(.RET,INP)
I NEW S RET=PICK
E S RET="-"_PICK
Q
NEW(SUBSET,NAME) ;Create a new picklist
N IEN,FDA,DIR,RET
S IEN="+1,"
S FDA(90362.34,IEN,.01)=NAME
S FDA(90362.34,IEN,.08)=SUBSET
S FDA(90362.34,IEN,.05)=DUZ
D UPDATE^DIE(,"FDA","IEN","ERR")
I $D(ERR) S RET=-1
E S RET=IEN(1)
I RET>0 D
.N INP,RET1
.S INP=RET_U_DUZ_U_1
.D SETMGR^BGOSNOPR(.RET1,INP)
Q RET
CONCLKUP(RET,CONCID) ;EP
;Changed to use new api
S CONCID=$G(CONCID)_"^^^1"
S RET=$$CONC^AUPNSICD(CONCID)
Q
GETSUB(RET,PREFIX) ;Return list of subsets to select from
N X,ARR,I,CNT
S RET=$$TMPGBL^BGOUTL
S PREFIX=$S($G(PREFIX)="":"PICK",1:$G(PREFIX))
S CNT=0
S X=$$SUBSET^BSTSAPI("ARR","36^1")
S I=0 F S I=$O(ARR(I)) Q:I="" D
.S NAME=$G(ARR(I))
.I $E(NAME,1,4)=PREFIX D
..S CNT=CNT+1
..S @RET@(CNT)=$G(ARR(I))
Q
TREAT(RET,VIEN) ;Find all the treatment/regimens
N FNUM,GRP,SUB,ARR,X,GRP,ITM,CNT,IN,OUT,X,VDT,FCNT
S RET=$$TMPGBL^BGOUTL
S SUB="TREG "
S X=$$SUBSET^BSTSAPI("ARR","36^1")
Q:X=0
S CNT=0,FCNT=0
S VDT=$$GET1^DIQ(9000010,VIEN,.01,"I")
F S CNT=$O(ARR(CNT)) Q:CNT="" D
.S NAME=$G(ARR(CNT))
.I $E(NAME,1,4)="TREG" D
..S GRP=$E(NAME,6,$L(NAME))
..D DATA(NAME,GRP,VDT)
Q
DATA(NAME,GRP,VDT) ;Get the subset data
N OUT,IN,X,Y,TXT,DESC,SNO,ICD,NODE,NUM
S OUT=$$SNOTMP
S IN=NAME_"^^1"
S X=$$SUBLST^BSTSAPI(.OUT,.IN)
;1 means success
I X>0 D
.S NUM="" F S NUM=$O(@OUT@(NUM)) Q:NUM="" D
..S NODE=$G(@OUT@(NUM))
..S SNO=$P(NODE,U,1)
..S DESC=$P(NODE,U,2)
..S TXT=$P(NODE,U,3)
..;IHS/MSC/MGH changed to use new API
..;S Y=$$CONC^BSTSAPI(SNO_"^^"_VDT_"^1")
..S Y=$$CONC^AUPNSICD(SNO_"^^"_VDT_"^1")
..I Y'="" S ICD=$P($P(Y,U,5),";",1)
..S FCNT=FCNT+1
..S @RET@(FCNT)=TXT_U_DESC_U_SNO_U_ICD_U_U_GRP
Q
UPPER(X) ;Turn value to upper case
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
BGOSNLK ; IHS/MSC/MGH - SNOMED Picklists ;05-Dec-2014 07:22;du
+1 ;;1.1;BGO COMPONENTS;**13,14**;Mar 20, 2007;Build 1
+2 ;Input is the name of the picklist
GETLST(RET,INP) ;Return items from a SNOMED picklist
+1 NEW FNUM,GRP,PICK,ITM,SNO,DESC,TXT,STAT,CNT,IN,OUT,X,DATA,ICD
+2 SET RET=$$TMPGBL^BGOUTL
+3 SET CNT=0
+4 SET FNUM=90362.34
+5 SET PICK=""
SET PICK=$ORDER(^BGOSNOPR("B",INP,PICK))
+6 IF PICK=""
QUIT
+7 SET ITM=0
FOR
SET ITM=$ORDER(^BGOSNOPR(PICK,1,ITM))
IF '+ITM
QUIT
Begin DoDot:1
+8 SET DATA=$GET(^BGOSNOPR(PICK,1,ITM,0))
+9 SET SNO=$PIECE(DATA,U,1)
+10 SET DESC=$PIECE(DATA,U,2)
+11 SET STAT=$PIECE(DATA,U,6)
+12 SET ICD=""
+13 SET GRP=$PIECE($GET(^BGOSNOPR(PICK,1,ITM,1)),U,2)
+14 ;look it up in Apelon
+15 ;changed to use new API
+16 ;S X=$$CONC^BSTSAPI(SNO_"^36^^1")
+17 SET X=$$CONC^AUPNSICD(SNO_"^^^1")
+18 IF $PIECE(X,U,1)'=""
Begin DoDot:2
+19 SET DESC=$PIECE(X,U,3)
+20 SET TXT=$PIECE(X,U,4)
+21 SET ICD=$PIECE(X,U,5)
End DoDot:2
+22 SET CNT=CNT+1
+23 SET @RET@(CNT)=TXT_U_DESC_U_SNO_U_ICD_U_STAT_U_GRP
End DoDot:1
+24 QUIT
SUBSET(RET,INP) ;Return data from a subset
+1 NEW CNT,SUBSET,IN,OUT,X,SNO,ICD,DESC,TXT
+2 SET CNT=0
+3 IF $GET(RET)=""
SET RET=$$TMPGBL^BGOUTL
+4 ;look it up in Apelon
+5 SET OUT=$$SNOTMP
+6 SET IN=INP_"^^1"
+7 SET X=$$SUBLST^BSTSAPI(.OUT,.IN)
+8 ;1 means success
+9 IF X>0
Begin DoDot:1
+10 SET CNT=""
FOR
SET CNT=$ORDER(@OUT@(CNT))
IF CNT=""
QUIT
Begin DoDot:2
+11 SET ICD=""
+12 SET NODE=$GET(@OUT@(CNT))
+13 SET SNO=$PIECE(NODE,U,1)
+14 ;IHS/MSC/MGH changed to use new api
+15 ;S X=$$CONC^BSTSAPI(SNO_"^36^^1")
+16 SET X=$$CONC^AUPNSICD(SNO_"^^^1")
+17 IF X'=""
SET ICD=$PIECE($PIECE(X,U,5),";",1)
+18 SET DESC=$PIECE(NODE,U,2)
SET TXT=$PIECE(NODE,U,3)
+19 SET @RET@(CNT)=TXT_U_DESC_U_SNO_U_ICD_U_""_U_TXT
End DoDot:2
End DoDot:1
+20 QUIT
SNOTMP() KILL ^TMP("BGOSN"_$GET(X),$JOB)
QUIT $NAME(^($JOB))
+1 ;
UPDATE() ;Update picklists from Apelon
+1 NEW X,ARR,I,RET
+2 SET X=$$SUBSET^BSTSAPI("ARR")
+3 SET I=0
FOR
SET I=$ORDER(ARR(I))
IF I=""
QUIT
Begin DoDot:1
+4 SET NAME=$GET(ARR(I))
+5 IF $EXTRACT(NAME,1,4)="PICK"
Begin DoDot:2
+6 SET IEN=""
SET IEN=$ORDER(^BGOSNOPR("SS",$EXTRACT(NAME,1,30),IEN))
+7 IF IEN=""
Begin DoDot:3
+8 SET PICK=$EXTRACT(NAME,6,$LENGTH(NAME))
+9 ;S PICK=$$UPPER(PICK)
+10 SET IEN=$$NEW(NAME,PICK)
End DoDot:3
+11 IF IEN=""
QUIT
+12 SET PICK=$PIECE($GET(^BGOSNOPR(IEN,0)),U,1)
+13 WRITE !,"Updating "_PICK
+14 DO IMPORT(.RET,NAME,PICK)
+15 IF $$UPPER($EXTRACT(PICK,1,8))="PRENATAL"
Begin DoDot:3
+16 NEW IENS,FDA,ERR
+17 SET IENS=IEN_","
+18 SET FDA(90362.34,IENS,.09)=1
+19 DO UPDATE^DIE(,"FDA","","ERR")
End DoDot:3
+20 SET INP=IEN_U_DUZ_U_1
+21 DO SETMGR^BGOSNOPR(.RET,INP)
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;Import data from an Apelon subset to a SNOMED picklist
+24 ;Input parameters
+25 ;1)The Apelon subset
+26 ;2)The name of the SNOMED picklist
IMPORT(RET,SUBSET,INP) ;EP
+1 NEW PICK,OUT,IN,X,NODE,CK,SNO,AIEN,FNUM,FDA,IEN,ERR,NEW
+2 SET NEW=0
+3 SET PICK=""
SET PICK=$ORDER(^BGOSNOPR("B",INP,PICK))
+4 IF PICK=""
SET NEW=1
SET PICK=$$NEW(SUBSET,INP)
+5 IF PICK<1
QUIT
+6 SET OUT=$$SNOTMP
+7 SET IN=SUBSET
+8 SET X=$$SUBLST^BSTSAPI(.OUT,.IN)
+9 ;1 means success
+10 IF X>0
Begin DoDot:1
+11 SET CNT=""
FOR
SET CNT=$ORDER(@OUT@(CNT))
IF CNT=""
QUIT
Begin DoDot:2
+12 SET NODE=$GET(@OUT@(CNT))
+13 SET SNO=$PIECE(NODE,U,1)
+14 ;Don't load again if its already there
+15 SET CK=$ORDER(^BGOSNOPR(PICK,1,"B",SNO,""))
+16 IF +CK
QUIT
+17 NEW FDA,IEN,ERR
+18 SET AIEN="+1,"_PICK_","
+19 SET FDA(90362.342,AIEN,.01)=SNO
+20 SET FDA(90362.342,AIEN,.02)=$PIECE(NODE,U,2)
+21 SET FDA(90362.342,AIEN,.03)=0
+22 SET FDA(90362.342,AIEN,6)=$PIECE(NODE,U,3)
+23 DO UPDATE^DIE(,"FDA","IEN","ERR")
+24 IF '$DATA(ERR)
SET RET=IEN(1)
+25 IF '$TEST
SET RET=RET_"-1^Error adding item"_SNO
End DoDot:2
+26 SET INP=PICK_U_DUZ_U_1
+27 DO SETMGR^BGOSNOPR(.RET,INP)
End DoDot:1
+28 IF NEW
SET RET=PICK
+29 IF '$TEST
SET RET="-"_PICK
+30 QUIT
NEW(SUBSET,NAME) ;Create a new picklist
+1 NEW IEN,FDA,DIR,RET
+2 SET IEN="+1,"
+3 SET FDA(90362.34,IEN,.01)=NAME
+4 SET FDA(90362.34,IEN,.08)=SUBSET
+5 SET FDA(90362.34,IEN,.05)=DUZ
+6 DO UPDATE^DIE(,"FDA","IEN","ERR")
+7 IF $DATA(ERR)
SET RET=-1
+8 IF '$TEST
SET RET=IEN(1)
+9 IF RET>0
Begin DoDot:1
+10 NEW INP,RET1
+11 SET INP=RET_U_DUZ_U_1
+12 DO SETMGR^BGOSNOPR(.RET1,INP)
End DoDot:1
+13 QUIT RET
CONCLKUP(RET,CONCID) ;EP
+1 ;Changed to use new api
+2 SET CONCID=$GET(CONCID)_"^^^1"
+3 SET RET=$$CONC^AUPNSICD(CONCID)
+4 QUIT
GETSUB(RET,PREFIX) ;Return list of subsets to select from
+1 NEW X,ARR,I,CNT
+2 SET RET=$$TMPGBL^BGOUTL
+3 SET PREFIX=$SELECT($GET(PREFIX)="":"PICK",1:$GET(PREFIX))
+4 SET CNT=0
+5 SET X=$$SUBSET^BSTSAPI("ARR","36^1")
+6 SET I=0
FOR
SET I=$ORDER(ARR(I))
IF I=""
QUIT
Begin DoDot:1
+7 SET NAME=$GET(ARR(I))
+8 IF $EXTRACT(NAME,1,4)=PREFIX
Begin DoDot:2
+9 SET CNT=CNT+1
+10 SET @RET@(CNT)=$GET(ARR(I))
End DoDot:2
End DoDot:1
+11 QUIT
TREAT(RET,VIEN) ;Find all the treatment/regimens
+1 NEW FNUM,GRP,SUB,ARR,X,GRP,ITM,CNT,IN,OUT,X,VDT,FCNT
+2 SET RET=$$TMPGBL^BGOUTL
+3 SET SUB="TREG "
+4 SET X=$$SUBSET^BSTSAPI("ARR","36^1")
+5 IF X=0
QUIT
+6 SET CNT=0
SET FCNT=0
+7 SET VDT=$$GET1^DIQ(9000010,VIEN,.01,"I")
+8 FOR
SET CNT=$ORDER(ARR(CNT))
IF CNT=""
QUIT
Begin DoDot:1
+9 SET NAME=$GET(ARR(CNT))
+10 IF $EXTRACT(NAME,1,4)="TREG"
Begin DoDot:2
+11 SET GRP=$EXTRACT(NAME,6,$LENGTH(NAME))
+12 DO DATA(NAME,GRP,VDT)
End DoDot:2
End DoDot:1
+13 QUIT
DATA(NAME,GRP,VDT) ;Get the subset data
+1 NEW OUT,IN,X,Y,TXT,DESC,SNO,ICD,NODE,NUM
+2 SET OUT=$$SNOTMP
+3 SET IN=NAME_"^^1"
+4 SET X=$$SUBLST^BSTSAPI(.OUT,.IN)
+5 ;1 means success
+6 IF X>0
Begin DoDot:1
+7 SET NUM=""
FOR
SET NUM=$ORDER(@OUT@(NUM))
IF NUM=""
QUIT
Begin DoDot:2
+8 SET NODE=$GET(@OUT@(NUM))
+9 SET SNO=$PIECE(NODE,U,1)
+10 SET DESC=$PIECE(NODE,U,2)
+11 SET TXT=$PIECE(NODE,U,3)
+12 ;IHS/MSC/MGH changed to use new API
+13 ;S Y=$$CONC^BSTSAPI(SNO_"^^"_VDT_"^1")
+14 SET Y=$$CONC^AUPNSICD(SNO_"^^"_VDT_"^1")
+15 IF Y'=""
SET ICD=$PIECE($PIECE(Y,U,5),";",1)
+16 SET FCNT=FCNT+1
+17 SET @RET@(FCNT)=TXT_U_DESC_U_SNO_U_ICD_U_U_GRP
End DoDot:2
End DoDot:1
+18 QUIT
UPPER(X) ;Turn value to upper case
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
