- BGOSNOP2 ; IHS/MSC/MGH - SNOMED PREFERENCES MANAGER 2 ;07-Apr-2016 07:54;du
- ;;1.1;BGO COMPONENTS;**13,14,20**;Mar 20, 2007;Build 1
- ; Clone a preference
- ; INP = Pref IEN (from) ^ Pref IEN (to)
- CLONE(RET,INP) ;EP
- N FROM,TO,ITM,SFN,GBL,FNUM,X1
- S FNUM=90362.34
- K RET
- S RET=$$GBLROOT^BGOPFUTL(FNUM,.GBL,.SFN)
- Q:RET
- I $G(INP)="" S RET=$$ERR^BGOUTL(1008) Q
- S FROM=+INP
- I 'FROM S RET=$$ERR^BGOUTL(1038) Q
- I '$D(@GBL@(FROM,0)) S RET=$$ERR^BGOUTL(1039) Q
- S TO=$P(INP,U,2)
- I 'TO S RET=$$ERR^BGOUTL(1040) Q
- I '$D(@GBL@(TO,0)) S RET=$$ERR^BGOUTL(1041) Q
- S ITM=0
- F S ITM=$O(@GBL@(FROM,1,ITM)) Q:'ITM D Q:RET
- .N FDA,X
- .Q:$O(@GBL@(TO,1,"B",ITM,0))
- .S X=@GBL@(FROM,1,ITM,0)
- .S X1=@GBL@(FROM,1,ITM,1)
- .S FDA=$NA(FDA(SFN,"+1,"_TO_","))
- .S @FDA@(.01)=+X
- .S @FDA@(.02)=$P(X,U,2)
- .S @FDA@(.03)=$P(X,U,3)
- .S @FDA@(6)=$P(X1,U,1)
- .S RET=$$UPDATE^BGOUTL(.FDA,"@")
- Q
- ; Execute query
- ; INP = Category IEN [1] ^ Provider IEN [2] ^ Clinic IEN [3] ^ Provider Class [4] ^ Hospital Location [5] ^
- ; Start Date [6] ^ End Date [7] ^ Max Hits [8]
- QUERY(RET,INP) ;EP
- N CAT,PRV,CLN,CLS,HL,BEGDT,ENDDT,VD,VIEN,VIS,PIEN,DX,ICD,REC,ICD,TXT,CNT,MAX,X
- N SNO,DESCT
- S RET=""
- S CAT=$P(INP,U)
- S PRV=$P(INP,U,2)
- S CLN=$P(INP,U,3)
- S CLS=$P(INP,U,4)
- S HL=$P(INP,U,5)
- S BEGDT=$P(INP,U,6)
- S ENDDT=$P(INP,U,7)
- S MAX=+$P(INP,U,8)
- I CLN="",CLS="",PRV="",HL="" S RET=$$ERR^BGOUTL(1022) Q
- S RET=$$QRYINIT^BGOPFUTL(90362.34,CAT)
- Q:RET
- S VD=$S(BEGDT:BEGDT,1:DT-20000)
- S:'ENDDT ENDDT=DT
- S CNT=0
- F S VD=$O(^AUPNVSIT("B",VD)) Q:'VD!RET!(VD>ENDDT) D
- .S VIEN=0
- .S VIEN=$O(^AUPNVSIT("B",VD,VIEN)) Q:'VIEN!RET D
- ..S VIS=$G(^AUPNVSIT(VIEN,0))
- ..Q:VIS=""
- ..I CLN,$P(VIS,U,8)'=CLN Q
- ..I HL,$P(VIS,U,22)'=HL Q
- ..I PRV!CLS,'$$VISPRCL^BGOPFUTL(VIEN,PRV,CLS) Q
- ..S DX=0
- ..F S DX=$O(^AUPNVPOV("AD",VIEN,DX)) Q:'DX!RET D
- ...S SNO=$P($G(^AUPNVPOV(DX,11)),U)
- ...I SNO'="" D
- ....S CNT=CNT+1
- ....S DESCT=$P($G(^AUPNVPOV(DX,11)),U,2)
- ....S:CNT=MAX RET=CNT
- ....S REC=^AUPNVPOV(DX,0)
- ....S TXT=$$GET1^DIQ(9000010.07,DX,.04)
- ....D QRYADD^BGOPFUTL(90362.34,CAT,SNO,TXT)
- S RET=$$QRYDONE^BGOPFUTL(90362.34,CAT)
- Q
- UPDITEM(FNUM,CAT,PTR,CNT,TXT,NEW,ITM) ;EP
- N FDA,IEN,GBL,SFN,RET,DESCT,X,IEN,ERR,SNO,TXT2
- S RET=$$GBLROOT^BGOPFUTL(FNUM,.GBL,.SFN)
- Q:RET RET
- S ITM=$S($G(NEW):0,1:$O(@GBL@(CAT,1,"B",PTR,0)))
- S:$E($G(CNT))="+" CNT=$S(ITM:$P(@GBL@(CAT,1,ITM,0),U,3),1:0)+CNT
- S FDA=$NA(FDA(SFN,$S(ITM:ITM,1:"+1")_","_CAT_","))
- ;IHS/MSC/MGH use new API
- ;S X=$$CONC^BSTSAPI(PTR_"^^^1")
- S X=$$CONC^AUPNSICD(PTR_"^^^1")
- S DESCT=$P(X,U,3),TXT2=$P(X,U,4)
- S @FDA@(.01)=PTR
- S:$D(CNT) @FDA@(.03)=CNT
- S:$G(DESCT) @FDA@(.02)=DESCT
- I TXT2'="" S @FDA@(6)=TXT2
- ;D UPDATE^DIE(,"FDA","IEN","ERR")
- ;I '$D(ERR),'ITM S ITM=IEN(1)
- S RET=$$UPDATE^BGOUTL(.FDA,"E@",.IEN)
- I 'RET,'ITM S ITM=IEN(1)
- Q RET
- UPSTAT(RET,PICK) ;Update status to default on a picklist
- N LP,OUT,BGOS,BGODEF,BGOSNO,IN,BGOSNO,BGODEF,DATA,SNODATA,FDA,BGODEF,DEFST
- S RET=0,CNT=0
- S SFN=90362.342
- ;Loop through all the SNOMEDS on the picklist
- S LP=0 F S LP=$O(^BGOSNOPR(PICK,1,LP)) Q:'+LP D
- .S BGOSNO=$P($G(^BGOSNOPR(PICK,1,LP,0)),U,1)
- .;get this snomed's default status
- .S SNODATA=$$CONC^AUPNSICD(BGOSNO_"^^^1")
- .S DEFST=$P(SNODATA,U,9)
- .S DEFST=$S(DEFST="Chronic":"A",DEFST="Sub-acute":"S",DEFST="Episodic":"E",DEFST="Social/Environmental":"O",DEFST="Routine/Admin":"R",DEFST="Admin":"R",1:"")
- .I DEFST'="" D
- ..S FDA=$NA(FDA(SFN,LP_","_PICK_","))
- ..S @FDA@(.06)=DEFST
- ..S @FDA@(.04)=$$NOW^XLFDT
- ..S DATA=$$UPDATE^BGOUTL(.FDA,"")
- ..I 'DATA S CNT=CNT+1
- ..K DATA
- S RET=CNT
- Q
- SETSUB ;
- N X,Y
- S X=$$SUBLST^BSTSAPI(OUT,IN)
- ;SET UP INDEX
- S Y=0 F S Y=$O(^TMP($J,BGOS,Y)) Q:Y'=+Y D
- .S X=$P(^TMP($J,BGOS,Y),U,1)
- .S ^TMP($J,"I",X,BGOS)=""
- .Q
- Q
- UPDATE ;Update all picklist items to default status
- N ZTRTN,TSK,ZTDESC
- W !,"Update all picklist items to default status",!!
- S ZTRTN="OUT^BGOSNOP2"
- S ZTDESC="Update picklists to default status"
- S TSK=$$QUEUE^CIAUTSK(ZTRTN,ZTDESC,"","","","","")
- W !,"Picklist update has scheduled task number: "_TSK
- Q
- OUT ;Update all subset with default status
- N IEN,SIEN,RET,PICK
- N LP,OUT,BGOS,BGODEF,BGOSNO,IN,BGOSNO,BGODEF,DATA,SFN,FDA
- S RET=0,CNT=0
- S SFN=90362.342
- S PICK=0
- ;Loop through the picklists
- S IEN=0 F S IEN=$O(^BGOSNOPR(IEN)) Q:'+IEN!(PICK>3) D
- .S PICK=PICK+1
- . ;Loop through all the SNOMEDS on the picklist
- .S LP=0 F S LP=$O(^BGOSNOPR(IEN,1,LP)) Q:'+LP D
- ..S BGOSNO=$P($G(^BGOSNOPR(IEN,1,LP,0)),U,1)
- ..;get this snomed's default status
- ..S SNODATA=$$CONC^AUPNSICD(BGOSNO_"^^^1")
- ..S DEFST=$P(SNODATA,U,9)
- ..S DEFST=$S(DEFST="Chronic":"A",DEFST="Sub-acute":"S",DEFST="Episodic":"E",DEFST="Social/Environmental":"O",DEFST="Routine/Admin":"R",DEFST="Admin":"R",1:"")
- ..I DEFST'="" D
- ...S FDA=$NA(FDA(SFN,LP_","_IEN_","))
- ...S @FDA@(.06)=DEFST
- ...S @FDA@(.04)=$$NOW^XLFDT
- ...S DATA=$$UPDATE^BGOUTL(.FDA,"")
- ...I 'DATA S CNT=CNT+1
- ...K DATA
- S RET=CNT
- Q
- BGOSNOP2 ; IHS/MSC/MGH - SNOMED PREFERENCES MANAGER 2 ;07-Apr-2016 07:54;du
- +1 ;;1.1;BGO COMPONENTS;**13,14,20**;Mar 20, 2007;Build 1
- +2 ; Clone a preference
- +3 ; INP = Pref IEN (from) ^ Pref IEN (to)
- CLONE(RET,INP) ;EP
- +1 NEW FROM,TO,ITM,SFN,GBL,FNUM,X1
- +2 SET FNUM=90362.34
- +3 KILL RET
- +4 SET RET=$$GBLROOT^BGOPFUTL(FNUM,.GBL,.SFN)
- +5 IF RET
- QUIT
- +6 IF $GET(INP)=""
- SET RET=$$ERR^BGOUTL(1008)
- QUIT
- +7 SET FROM=+INP
- +8 IF 'FROM
- SET RET=$$ERR^BGOUTL(1038)
- QUIT
- +9 IF '$DATA(@GBL@(FROM,0))
- SET RET=$$ERR^BGOUTL(1039)
- QUIT
- +10 SET TO=$PIECE(INP,U,2)
- +11 IF 'TO
- SET RET=$$ERR^BGOUTL(1040)
- QUIT
- +12 IF '$DATA(@GBL@(TO,0))
- SET RET=$$ERR^BGOUTL(1041)
- QUIT
- +13 SET ITM=0
- +14 FOR
- SET ITM=$ORDER(@GBL@(FROM,1,ITM))
- IF 'ITM
- QUIT
- Begin DoDot:1
- +15 NEW FDA,X
- +16 IF $ORDER(@GBL@(TO,1,"B",ITM,0))
- QUIT
- +17 SET X=@GBL@(FROM,1,ITM,0)
- +18 SET X1=@GBL@(FROM,1,ITM,1)
- +19 SET FDA=$NAME(FDA(SFN,"+1,"_TO_","))
- +20 SET @FDA@(.01)=+X
- +21 SET @FDA@(.02)=$PIECE(X,U,2)
- +22 SET @FDA@(.03)=$PIECE(X,U,3)
- +23 SET @FDA@(6)=$PIECE(X1,U,1)
- +24 SET RET=$$UPDATE^BGOUTL(.FDA,"@")
- End DoDot:1
- IF RET
- QUIT
- +25 QUIT
- +26 ; Execute query
- +27 ; INP = Category IEN [1] ^ Provider IEN [2] ^ Clinic IEN [3] ^ Provider Class [4] ^ Hospital Location [5] ^
- +28 ; Start Date [6] ^ End Date [7] ^ Max Hits [8]
- QUERY(RET,INP) ;EP
- +1 NEW CAT,PRV,CLN,CLS,HL,BEGDT,ENDDT,VD,VIEN,VIS,PIEN,DX,ICD,REC,ICD,TXT,CNT,MAX,X
- +2 NEW SNO,DESCT
- +3 SET RET=""
- +4 SET CAT=$PIECE(INP,U)
- +5 SET PRV=$PIECE(INP,U,2)
- +6 SET CLN=$PIECE(INP,U,3)
- +7 SET CLS=$PIECE(INP,U,4)
- +8 SET HL=$PIECE(INP,U,5)
- +9 SET BEGDT=$PIECE(INP,U,6)
- +10 SET ENDDT=$PIECE(INP,U,7)
- +11 SET MAX=+$PIECE(INP,U,8)
- +12 IF CLN=""
- IF CLS=""
- IF PRV=""
- IF HL=""
- SET RET=$$ERR^BGOUTL(1022)
- QUIT
- +13 SET RET=$$QRYINIT^BGOPFUTL(90362.34,CAT)
- +14 IF RET
- QUIT
- +15 SET VD=$SELECT(BEGDT:BEGDT,1:DT-20000)
- +16 IF 'ENDDT
- SET ENDDT=DT
- +17 SET CNT=0
- +18 FOR
- SET VD=$ORDER(^AUPNVSIT("B",VD))
- IF 'VD!RET!(VD>ENDDT)
- QUIT
- Begin DoDot:1
- +19 SET VIEN=0
- +20 SET VIEN=$ORDER(^AUPNVSIT("B",VD,VIEN))
- IF 'VIEN!RET
- QUIT
- Begin DoDot:2
- +21 SET VIS=$GET(^AUPNVSIT(VIEN,0))
- +22 IF VIS=""
- QUIT
- +23 IF CLN
- IF $PIECE(VIS,U,8)'=CLN
- QUIT
- +24 IF HL
- IF $PIECE(VIS,U,22)'=HL
- QUIT
- +25 IF PRV!CLS
- IF '$$VISPRCL^BGOPFUTL(VIEN,PRV,CLS)
- QUIT
- +26 SET DX=0
- +27 FOR
- SET DX=$ORDER(^AUPNVPOV("AD",VIEN,DX))
- IF 'DX!RET
- QUIT
- Begin DoDot:3
- +28 SET SNO=$PIECE($GET(^AUPNVPOV(DX,11)),U)
- +29 IF SNO'=""
- Begin DoDot:4
- +30 SET CNT=CNT+1
- +31 SET DESCT=$PIECE($GET(^AUPNVPOV(DX,11)),U,2)
- +32 IF CNT=MAX
- SET RET=CNT
- +33 SET REC=^AUPNVPOV(DX,0)
- +34 SET TXT=$$GET1^DIQ(9000010.07,DX,.04)
- +35 DO QRYADD^BGOPFUTL(90362.34,CAT,SNO,TXT)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +36 SET RET=$$QRYDONE^BGOPFUTL(90362.34,CAT)
- +37 QUIT
- UPDITEM(FNUM,CAT,PTR,CNT,TXT,NEW,ITM) ;EP
- +1 NEW FDA,IEN,GBL,SFN,RET,DESCT,X,IEN,ERR,SNO,TXT2
- +2 SET RET=$$GBLROOT^BGOPFUTL(FNUM,.GBL,.SFN)
- +3 IF RET
- QUIT RET
- +4 SET ITM=$SELECT($GET(NEW):0,1:$ORDER(@GBL@(CAT,1,"B",PTR,0)))
- +5 IF $EXTRACT($GET(CNT))="+"
- SET CNT=$SELECT(ITM:$PIECE(@GBL@(CAT,1,ITM,0),U,3),1:0)+CNT
- +6 SET FDA=$NAME(FDA(SFN,$SELECT(ITM:ITM,1:"+1")_","_CAT_","))
- +7 ;IHS/MSC/MGH use new API
- +8 ;S X=$$CONC^BSTSAPI(PTR_"^^^1")
- +9 SET X=$$CONC^AUPNSICD(PTR_"^^^1")
- +10 SET DESCT=$PIECE(X,U,3)
- SET TXT2=$PIECE(X,U,4)
- +11 SET @FDA@(.01)=PTR
- +12 IF $DATA(CNT)
- SET @FDA@(.03)=CNT
- +13 IF $GET(DESCT)
- SET @FDA@(.02)=DESCT
- +14 IF TXT2'=""
- SET @FDA@(6)=TXT2
- +15 ;D UPDATE^DIE(,"FDA","IEN","ERR")
- +16 ;I '$D(ERR),'ITM S ITM=IEN(1)
- +17 SET RET=$$UPDATE^BGOUTL(.FDA,"E@",.IEN)
- +18 IF 'RET
- IF 'ITM
- SET ITM=IEN(1)
- +19 QUIT RET
- UPSTAT(RET,PICK) ;Update status to default on a picklist
- +1 NEW LP,OUT,BGOS,BGODEF,BGOSNO,IN,BGOSNO,BGODEF,DATA,SNODATA,FDA,BGODEF,DEFST
- +2 SET RET=0
- SET CNT=0
- +3 SET SFN=90362.342
- +4 ;Loop through all the SNOMEDS on the picklist
- +5 SET LP=0
- FOR
- SET LP=$ORDER(^BGOSNOPR(PICK,1,LP))
- IF '+LP
- QUIT
- Begin DoDot:1
- +6 SET BGOSNO=$PIECE($GET(^BGOSNOPR(PICK,1,LP,0)),U,1)
- +7 ;get this snomed's default status
- +8 SET SNODATA=$$CONC^AUPNSICD(BGOSNO_"^^^1")
- +9 SET DEFST=$PIECE(SNODATA,U,9)
- +10 SET DEFST=$SELECT(DEFST="Chronic":"A",DEFST="Sub-acute":"S",DEFST="Episodic":"E",DEFST="Social/Environmental":"O",DEFST="Routine/Admin":"R",DEFST="Admin":"R",1:"")
- +11 IF DEFST'=""
- Begin DoDot:2
- +12 SET FDA=$NAME(FDA(SFN,LP_","_PICK_","))
- +13 SET @FDA@(.06)=DEFST
- +14 SET @FDA@(.04)=$$NOW^XLFDT
- +15 SET DATA=$$UPDATE^BGOUTL(.FDA,"")
- +16 IF 'DATA
- SET CNT=CNT+1
- +17 KILL DATA
- End DoDot:2
- End DoDot:1
- +18 SET RET=CNT
- +19 QUIT
- SETSUB ;
- +1 NEW X,Y
- +2 SET X=$$SUBLST^BSTSAPI(OUT,IN)
- +3 ;SET UP INDEX
- +4 SET Y=0
- FOR
- SET Y=$ORDER(^TMP($JOB,BGOS,Y))
- IF Y'=+Y
- QUIT
- Begin DoDot:1
- +5 SET X=$PIECE(^TMP($JOB,BGOS,Y),U,1)
- +6 SET ^TMP($JOB,"I",X,BGOS)=""
- +7 QUIT
- End DoDot:1
- +8 QUIT
- UPDATE ;Update all picklist items to default status
- +1 NEW ZTRTN,TSK,ZTDESC
- +2 WRITE !,"Update all picklist items to default status",!!
- +3 SET ZTRTN="OUT^BGOSNOP2"
- +4 SET ZTDESC="Update picklists to default status"
- +5 SET TSK=$$QUEUE^CIAUTSK(ZTRTN,ZTDESC,"","","","","")
- +6 WRITE !,"Picklist update has scheduled task number: "_TSK
- +7 QUIT
- OUT ;Update all subset with default status
- +1 NEW IEN,SIEN,RET,PICK
- +2 NEW LP,OUT,BGOS,BGODEF,BGOSNO,IN,BGOSNO,BGODEF,DATA,SFN,FDA
- +3 SET RET=0
- SET CNT=0
- +4 SET SFN=90362.342
- +5 SET PICK=0
- +6 ;Loop through the picklists
- +7 SET IEN=0
- FOR
- SET IEN=$ORDER(^BGOSNOPR(IEN))
- IF '+IEN!(PICK>3)
- QUIT
- Begin DoDot:1
- +8 SET PICK=PICK+1
- +9 ;Loop through all the SNOMEDS on the picklist
- +10 SET LP=0
- FOR
- SET LP=$ORDER(^BGOSNOPR(IEN,1,LP))
- IF '+LP
- QUIT
- Begin DoDot:2
- +11 SET BGOSNO=$PIECE($GET(^BGOSNOPR(IEN,1,LP,0)),U,1)
- +12 ;get this snomed's default status
- +13 SET SNODATA=$$CONC^AUPNSICD(BGOSNO_"^^^1")
- +14 SET DEFST=$PIECE(SNODATA,U,9)
- +15 SET DEFST=$SELECT(DEFST="Chronic":"A",DEFST="Sub-acute":"S",DEFST="Episodic":"E",DEFST="Social/Environmental":"O",DEFST="Routine/Admin":"R",DEFST="Admin":"R",1:"")
- +16 IF DEFST'=""
- Begin DoDot:3
- +17 SET FDA=$NAME(FDA(SFN,LP_","_IEN_","))
- +18 SET @FDA@(.06)=DEFST
- +19 SET @FDA@(.04)=$$NOW^XLFDT
- +20 SET DATA=$$UPDATE^BGOUTL(.FDA,"")
- +21 IF 'DATA
- SET CNT=CNT+1
- +22 KILL DATA
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +23 SET RET=CNT
- +24 QUIT
