BJPNPKL ;GDIT/HS/BEE-Prenatal Care Module Pick List ; 08 May 2012 12:00 PM
;;2.0;PRENATAL CARE MODULE;**3,7**;Feb 24, 2015;Build 53
;
Q
;
LST(DATA,FAKE) ;EP - BJPN GET PICK LISTS
;
;This RPC returns top level entries from the BGO SNOMED PREFERENCES file (#90362.34)
;
NEW UID,II,IEN
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPKL",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPKL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
S @DATA@(II)="I00010HIDDEN_PLIEN^T00030PICK_LISTS^T00001SET_POV"_$C(30)
;
S IEN=0 F S IEN=$O(^BGOSNOPR(IEN)) Q:'IEN D
. ;
. NEW NAME,POV
. ;
. ;Only include PIP Pick Lists
. I '$$GET1^DIQ(90362.34,IEN_",",".09","I") Q
. ;
. ;Skip if it doesn't have any entries
. I '+$O(^BGOSNOPR(IEN,1,0)) Q
. ;Name
. S NAME=$$GET1^DIQ(90362.34,IEN_",",".01","E") Q:NAME=""
. ;
. ;Return whether to allow POV Set
. S POV=$$GET1^DIQ(90362.34,IEN_",","1.1","I")
. ;
. S II=II+1,@DATA@(II)=IEN_U_NAME_U_POV_$C(30)
;
S II=II+1,@DATA@(II)=$C(31)
;
Q
;
SNO(DATA,DFN) ;EP - BJPN GET SNOMED TERMS
;
;This RPC returns entries from the BJPN SNOMED TERMS file (#90680.02)
;If the DFN is supplied, it returns whether the patient has that problem
;on their PIP
;
;Input: DFN (Optional) - Patient DFN
;
S DFN=$G(DFN)
;
NEW UID,II,PSTS,RFEDD,PREDD,ICD
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPRL",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPKL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
S @DATA@(II)="I00010HIDDEN_PKIEN^T00150SNOMED_TERM^T00250FULL_NAME^T00025CONCEPT_ID^T00001PIP^T00010ICD"_$C(30)
;
S TRM="" F S TRM=$O(^BJPN(90680.02,"C",TRM)) Q:TRM="" D
. S IEN="" F S IEN=$O(^BJPN(90680.02,"C",TRM,IEN)) Q:IEN="" D
.. NEW TRM,FSPNM,CAT,CIEN,IENS,CONC,FREQ,PIP,PLIEN,ICIEN
.. ;
.. ;SNOMED TERM
.. S TRM=$$GET1^DIQ(90680.02,IEN_",",.02,"E") Q:TRM=""
.. ;
.. ;FULLY SPECIFIED NAME
.. S FSPNM=$$GET1^DIQ(90680.02,IEN_",",3,"E")
.. ;
.. ;CONCEPT ID
.. S CONC=$$GET1^DIQ(90680.02,IEN_",",.07,"E") Q:CONC=""
.. ;
.. ;Code on Problem List
.. S PIP="N"
.. I DFN]"" S PLIEN="" F S PLIEN=$O(^BJPNPL("AC",DFN,IEN,PLIEN)) Q:PLIEN="" D
... NEW DEL
... I $$GET1^DIQ(90680.01,PLIEN_",",2.01,"I")]"" Q
... S PIP="Y"
.. ;
.. ;Pull the ICD-9
.. S ICD=""
.. S ICIEN=0 F S ICIEN=$O(^BJPN(90680.02,IEN,1,ICIEN)) Q:'ICIEN D
... ;
... NEW ICD9,ICDTP,DA,IENS
... S DA(1)=IEN,DA=ICIEN,IENS=$$IENS^DILF(.DA)
... S ICD9=$$GET1^DIQ(90680.21,IENS,.01,"E") Q:ICD9=""
... S ICDTP=$$GET1^DIQ(90680.21,IENS,.02,"I") I ICDTP'=1 Q
... S ICD=ICD_$S(ICD]"":";",1:"")_ICD9
.. S:ICD="" ICD=".9999"
.. ;
.. S II=II+1,@DATA@(II)=IEN_U_TRM_U_FSPNM_U_CONC_U_PIP_U_ICD_$C(30)
;
S II=II+1,@DATA@(II)=$C(31)
Q
;
PICK(DATA,PLIEN,DFN) ;EP - BJPN GET PICK LIST
;
;This RPC returns entries from the BGO SNOMED PREFERENCES file (#90362.34).
;It will return all SNOMED entries for a particular Pick List Entry.
;
;If the DFN is supplied, it returns whether the patient has that Concept ID
;
;Input: PLIEN (Optional) - Pick List IEN (Master if null)
; DFN (Optional) - Patient DFN
;
S DFN=$G(DFN)
S PLIEN=$G(PLIEN)
;
NEW UID,II,TRM,IEN,PRBLST
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPKL",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
S II=0
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPKL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
S @DATA@(II)="T00025DESC_ID^T00150SNOMED_TERM^T00250FULL_NAME^T00025CONCEPT_ID^I00010FREQ^T00010PIP^T00010ICD"
S @DATA@(II)=@DATA@(II)_"^T00001DISABLE^T00020DEF_STS^T00001CLASS^T00040GROUP^T00001PROMPT_LATERALITY"_$C(30)
;
;First get a list of the current PIP items
I DFN]"" D
. NEW PRBIEN
. S PRBIEN="" F S PRBIEN=$O(^BJPNPL("F",DFN,PRBIEN)) Q:PRBIEN="" D
.. NEW BPIEN
.. S BPIEN="" F S BPIEN=$O(^BJPNPL("F",DFN,PRBIEN,BPIEN)) Q:BPIEN="" D
... NEW DEL,CONCID,DESCID
... ;
... ;Skip deletes
... S DEL=$$GET1^DIQ(90680.01,BPIEN_",",2.01,"I") Q:DEL]"" ;PIP Delete
... S DEL=$$GET1^DIQ(9000011,PRBIEN_",",2.02,"I") I DEL]"" D Q ;IPL Delete
.... ;
.... ;If deleted on IPL, need to delete in PIP
.... NEW BJPNUPD,ERROR
.... S BJPNUPD(90680.01,BPIEN_",",2.01)=$$GET1^DIQ(9000011,PRBIEN_",",2.01,"I") ;Deleted By
.... S BJPNUPD(90680.01,BPIEN_",",2.02)=$$GET1^DIQ(9000011,PRBIEN_",",2.02,"I") ;Del Dt/Tm
.... S BJPNUPD(90680.01,BPIEN_",",2.03)=$$GET1^DIQ(9000011,PRBIEN_",",2.03,"I") ;Del Rsn
.... S BJPNUPD(90680.01,BPIEN_",",2.04)=$$GET1^DIQ(9000011,PRBIEN_",",2.04,"I") ;Del Other
.... D FILE^DIE("","BJPNUPD","ERROR")
... ;
... ;Get the IPL Concept ID and Description ID
... S CONCID=$$GET1^DIQ(9000011,PRBIEN_",",80001,"I") Q:CONCID=""
... S DESCID=$$GET1^DIQ(9000011,PRBIEN_",",80002,"I") Q:DESCID=""
... ;
... ;Save the problem entry into array
... S PRBLST(CONCID)=DESCID
;
;Process list passed in
I +PLIEN D LIST(+PLIEN,.PK,0)
;
;Process all lists
I 'PLIEN D
. NEW PLIEN,PK
. S PLIEN=0 F S PLIEN=$O(^BGOSNOPR(PLIEN)) Q:'PLIEN D
.. ;
.. ;Filter out non-PIP pick lists
.. Q:'$$GET1^DIQ(90362.34,PLIEN_",",.09,"I")
.. ;
.. ;Assemble the list
.. D LIST(+PLIEN,.PK,1)
;.. NEW CTIEN,SMDSTR
;.. S CTIEN=0 F S CTIEN=$O(^BGOSNOPR(+PLIEN,1,CTIEN)) Q:'CTIEN D
;... NEW CONCID,DESC,DESCTM,DA,IENS,FREQ,FNAME,ICD,PIP,DISABLE
;... S DA(1)=+PLIEN,DA=CTIEN,IENS=$$IENS^DILF(.DA)
;... S DESC=$$GET1^DIQ(90362.342,IENS,".02","I") Q:DESC=""
;... ;
;... ;Quit if already set
;... Q:$D(PK(DESC))
;... ;
;... S CONCID=$$GET1^DIQ(90362.342,IENS,".01","I") Q:CONCID=""
;... S DESCTM=$$GET1^DIQ(90362.342,IENS,"6","I") Q:DESCTM=""
;... S FREQ=$$GET1^DIQ(90362.342,IENS,".03","I") S:FREQ="" FREQ=0
;... S SMDSTR=$$CONC^BSTSAPI(CONCID_"^^"_DT_"^1")
;... S FNAME=$P(SMDSTR,U,2)
;... S ICD=$P(SMDSTR,U,5)
;... ;
;... ;Code on PIP?
;... S PIP="N",DISABLE=""
;... I DFN]"" D
;.... Q:'$D(PRBLST(CONCID))
;.... ;
;.... ;Mark as on PIP
;.... S PIP="Y"
;.... ;
;.... ;Disable if not the same synonym
;.... I DESC'=PRBLST(CONCID) S DISABLE="Y"
;... ;
;... ;Save the entry
;... S II=II+1,@DATA@(II)=DESC_U_DESCTM_U_FNAME_U_CONCID_U_FREQ_U_PIP_U_ICD_U_DISABLE_U_STS_U_CLASS_U_GROUP_U_LAT_$C(30)
;... ;
;... ;Flag entry so it will only be sent once
;... S PK(DESC)=""
;
XPICK S II=II+1,@DATA@(II)=$C(31)
Q
;
;Now loop through BGO SNOMED PREFERENCES file (#90362.34) for the picklist and return each entry
LIST(PLIEN,PK,ALL) ;
NEW CTIEN
S CTIEN=0 F S CTIEN=$O(^BGOSNOPR(+PLIEN,1,CTIEN)) Q:'CTIEN D
. NEW CONCID,DESC,DESCTM,DA,IENS,FREQ,FNAME,ICD,PIP,DISABLE,STS,CLASS,GROUP,LAT,BGON0,BGON1,CSTS,CRSLT,IIEN
. ;BJPN*2.0*7;Since picklists are so large avoid FileMan calls
. ;S DA(1)=+PLIEN,DA=CTIEN,IENS=$$IENS^DILF(.DA)
. ;S DESC=$$GET1^DIQ(90362.342,IENS,".02","I") Q:DESC=""
. ;S CONCID=$$GET1^DIQ(90362.342,IENS,".01","I") Q:CONCID=""
. ;S DESCTM=$$GET1^DIQ(90362.342,IENS,"6","I") Q:DESCTM=""
. ;S FREQ=$$GET1^DIQ(90362.342,IENS,".03","I") S:FREQ="" FREQ=0
. ;S SMDSTR=$$CONC^BSTSAPI(CONCID_"^^"_DT_"^1")
. ;S FNAME=$P(SMDSTR,U,2)
. ;S ICD=$P(SMDSTR,U,5)
. S BGON0=$G(^BGOSNOPR(+PLIEN,1,CTIEN,0))
. S BGON1=$G(^BGOSNOPR(+PLIEN,1,CTIEN,1))
. S DESC=$P(BGON0,U,2) Q:DESC=""
. S CONCID=$P(BGON0,U,1) Q:CONCID=""
. S FREQ=$P(BGON0,U,3) S:FREQ="" FREQ=0
. S GROUP=$P(BGON1,U,2)
. ;
. ;If show all do not use groups
. I ALL S GROUP=""
. ;
. I ALL Q:$D(PK(DESC))
. ;
. ;Call BSTS to get needed information
. S CSTS=$$DSCLKP^BSTSAPI("CRSLT",DESC)
. ;
. S FNAME=$G(CRSLT(1,"FSN","TRM")) ;FSN
. S IIEN=0,ICD="" F S IIEN=$O(CRSLT(1,"ICD",IIEN)) Q:'IIEN S ICD=ICD_$S(ICD]"":";",1:"")_$G(CRSLT(1,"ICD",IIEN,"COD")) ;ICD
. S DESCTM=$G(CRSLT(1,"PRB","TRM"))
. S LAT=$G(CRSLT(1,"LAT")),LAT=$S(LAT=1:"Y",1:"")
. ;
. ;Retrieve the default status
. ;Cannot use FileMan to retrieve the information because of a bug in the code in the EHR Pick List
. ;save logic that is saving the values incorrectly
. S CLASS="",STS=$P(BGON0,U,6)
. S:STS="Personal History" STS="P" ;Handle bug in EHR picklist code
. I STS="P" S CLASS="P"
. ;
. ;Custom code to account for EHR bug
. S STS=$S(STS="A":"Chronic",STS="S":"Sub-acute",STS="I":"Inactive",STS="E":"Episodic",STS="O":"Social/Environmental",STS="P":"Personal History",STS="R":"Admin",1:"Episodic")
. ;
. ;For show all use default status
. I ALL S STS=$G(CRSLT(1,"STS"))
. ;
. ;Code on PIP?
. S PIP="",DISABLE=""
. I DFN]"" D
.. Q:'$D(PRBLST(CONCID))
.. ;
.. ;Mark as on PIP
.. S PIP="On PIP"
.. ;
.. ;Disable if not the same synonym
.. I DESC'=PRBLST(CONCID) S DISABLE="Y"
. ;
. ;Save the entry
. S II=II+1,@DATA@(II)=DESC_U_DESCTM_U_FNAME_U_CONCID_U_FREQ_U_PIP_U_ICD_U_DISABLE_U_STS_U_CLASS_U_GROUP_U_LAT_$C(30)
. ;
. ;Record that it was found
. S PK(DESC)=""
;
Q
;
PPRV(VIEN) ;EP - Retrieve Visit Primary Provider
;
NEW PPRV,IEN
;
I $G(VIEN)="" Q ""
;
S (PPRV,IEN)="" F S IEN=$O(^AUPNVPRV("AD",VIEN,IEN)) Q:'IEN D Q:PPRV]""
. NEW PTYPE
. S PTYPE=$$GET1^DIQ(9000010.06,IEN_",",.04,"I") Q:PTYPE'="P"
. S PPRV=$$GET1^DIQ(9000010.06,IEN_",",.01,"I")
Q PPRV
;
DEL(DATA,VIEN,DESCID,DCODE,DRSN,IPLDEL) ;BJPN PICK LIST PRB DELETE
;
;Delete prenatal problem from PIP
;
;Input:
; VIEN - Visit IEN
; DESCID - Description Id of Problem to Remove
; DCODE - Delete Code
; DRSN - Delete Reason (if Other)
; IPLDEL - Delete IPL entry
;
NEW UID,II,%,DFN,CONCID,PRBIEN,PIPIEN,RSLT
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPKL",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPKL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
S @DATA@(II)="T00010RESULT^T00150ERROR_MESSAGE"_$C(30)
;
;Input validation
I $G(VIEN)="" S II=II+1,@DATA@(II)="-1^MISSING VISIT IEN"_$C(30) G XDEL
I $G(DESCID)="" S II=II+1,@DATA@(II)="-1^MISSING Description ID"_$C(30) G XDEL
S DCODE=$G(DCODE,""),DRSN=$G(DRSN,"")
S DFN=$$GET1^DIQ(9000010,VIEN_",",".05","I") I DFN="" S II=II+1,@DATA@(II)="-1^INVALID DFN"_$C(30) G XDEL
;
;Get the Concept ID
S CONCID=$P($$DESC^BSTSAPI(DESCID_"^^1"),U) I CONCID="" S II=II+1,@DATA@(II)="-1^COULD NOT FIND CONCEPT ID"_$C(30) G XDEL
;
;Locate the PIP entry
S (PIPIEN,PRBIEN)=""
F S PRBIEN=$O(^BJPNPL("F",DFN,PRBIEN)) Q:PRBIEN="" D Q:PIPIEN
. NEW BPIEN,IPLCNC,DEL
. ;
. ;Skip deletes
. S DEL=$$GET1^DIQ(9000011,PRBIEN_",",2.02,"I") I DEL]"" Q ;IPL Delete
. ;
. ;Get the Concept Id of the IPL entry - Look for a match
. S IPLCNC=$$GET1^DIQ(9000011,PRBIEN_",",80001,"I") Q:IPLCNC=""
. I IPLCNC'=CONCID Q
. ;
. ;Verify the PIPIEN is correct
. S BPIEN="" F S BPIEN=$O(^BJPNPL("F",DFN,PRBIEN,BPIEN)) Q:BPIEN="" D
.. NEW DEL
.. ;
.. ;Skip deletes
.. S DEL=$$GET1^DIQ(90680.01,BPIEN_",",2.01,"I") I DEL]"" Q
.. ;
.. ;Set the PIPIEN
.. S PIPIEN=BPIEN
;
;Quit if no PIP entry found
I ($G(PIPIEN)="")!($G(PRBIEN)="") S II=II+1,@DATA@(II)="-1^COULD NOT FIND PROBLEM ON PIP"_$C(30) G XDEL
;
;Make the call to delete
D DEL^BJPNCPIP("",VIEN,PIPIEN,DCODE,DRSN,$G(IPLDEL))
;
;Get the result
S RSLT=$P($G(^TMP("BJPNCPIP",UID,1)),$C(30))
S II=II+1,@DATA@(II)=$P(RSLT,U)_U_$P(RSLT,U,2)_$C(30)
;
;Broadcast update
;BJPN*2.0*7;Removed PPL - This call isn't used but made the fix just in case
D FIREEV^BJPNPDET("","PCC."_DFN_".PPL")
D FIREEV^BJPNPDET("","PCC."_DFN_".PIP")
;
XDEL S II=II+1,@DATA@(II)=$C(31)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S II=II+1,@DATA@(II)=$C(31)
Q
BJPNPKL ;GDIT/HS/BEE-Prenatal Care Module Pick List ; 08 May 2012 12:00 PM
+1 ;;2.0;PRENATAL CARE MODULE;**3,7**;Feb 24, 2015;Build 53
+2 ;
+3 QUIT
+4 ;
LST(DATA,FAKE) ;EP - BJPN GET PICK LISTS
+1 ;
+2 ;This RPC returns top level entries from the BGO SNOMED PREFERENCES file (#90362.34)
+3 ;
+4 NEW UID,II,IEN
+5 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+6 SET DATA=$NAME(^TMP("BJPNPKL",UID))
+7 KILL @DATA
+8 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+9 ;
+10 SET II=0
+11 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPKL D UNWIND^%ZTER"
+12 ;
+13 SET @DATA@(II)="I00010HIDDEN_PLIEN^T00030PICK_LISTS^T00001SET_POV"_$CHAR(30)
+14 ;
+15 SET IEN=0
FOR
SET IEN=$ORDER(^BGOSNOPR(IEN))
IF 'IEN
QUIT
Begin DoDot:1
+16 ;
+17 NEW NAME,POV
+18 ;
+19 ;Only include PIP Pick Lists
+20 IF '$$GET1^DIQ(90362.34,IEN_",",".09","I")
QUIT
+21 ;
+22 ;Skip if it doesn't have any entries
+23 IF '+$ORDER(^BGOSNOPR(IEN,1,0))
QUIT
+24 ;Name
+25 SET NAME=$$GET1^DIQ(90362.34,IEN_",",".01","E")
IF NAME=""
QUIT
+26 ;
+27 ;Return whether to allow POV Set
+28 SET POV=$$GET1^DIQ(90362.34,IEN_",","1.1","I")
+29 ;
+30 SET II=II+1
SET @DATA@(II)=IEN_U_NAME_U_POV_$CHAR(30)
End DoDot:1
+31 ;
+32 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+33 ;
+34 QUIT
+35 ;
SNO(DATA,DFN) ;EP - BJPN GET SNOMED TERMS
+1 ;
+2 ;This RPC returns entries from the BJPN SNOMED TERMS file (#90680.02)
+3 ;If the DFN is supplied, it returns whether the patient has that problem
+4 ;on their PIP
+5 ;
+6 ;Input: DFN (Optional) - Patient DFN
+7 ;
+8 SET DFN=$GET(DFN)
+9 ;
+10 NEW UID,II,PSTS,RFEDD,PREDD,ICD
+11 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+12 SET DATA=$NAME(^TMP("BJPNPRL",UID))
+13 KILL @DATA
+14 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+15 ;
+16 SET II=0
+17 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPKL D UNWIND^%ZTER"
+18 ;
+19 SET @DATA@(II)="I00010HIDDEN_PKIEN^T00150SNOMED_TERM^T00250FULL_NAME^T00025CONCEPT_ID^T00001PIP^T00010ICD"_$CHAR(30)
+20 ;
+21 SET TRM=""
FOR
SET TRM=$ORDER(^BJPN(90680.02,"C",TRM))
IF TRM=""
QUIT
Begin DoDot:1
+22 SET IEN=""
FOR
SET IEN=$ORDER(^BJPN(90680.02,"C",TRM,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+23 NEW TRM,FSPNM,CAT,CIEN,IENS,CONC,FREQ,PIP,PLIEN,ICIEN
+24 ;
+25 ;SNOMED TERM
+26 SET TRM=$$GET1^DIQ(90680.02,IEN_",",.02,"E")
IF TRM=""
QUIT
+27 ;
+28 ;FULLY SPECIFIED NAME
+29 SET FSPNM=$$GET1^DIQ(90680.02,IEN_",",3,"E")
+30 ;
+31 ;CONCEPT ID
+32 SET CONC=$$GET1^DIQ(90680.02,IEN_",",.07,"E")
IF CONC=""
QUIT
+33 ;
+34 ;Code on Problem List
+35 SET PIP="N"
+36 IF DFN]""
SET PLIEN=""
FOR
SET PLIEN=$ORDER(^BJPNPL("AC",DFN,IEN,PLIEN))
IF PLIEN=""
QUIT
Begin DoDot:3
+37 NEW DEL
+38 IF $$GET1^DIQ(90680.01,PLIEN_",",2.01,"I")]""
QUIT
+39 SET PIP="Y"
End DoDot:3
+40 ;
+41 ;Pull the ICD-9
+42 SET ICD=""
+43 SET ICIEN=0
FOR
SET ICIEN=$ORDER(^BJPN(90680.02,IEN,1,ICIEN))
IF 'ICIEN
QUIT
Begin DoDot:3
+44 ;
+45 NEW ICD9,ICDTP,DA,IENS
+46 SET DA(1)=IEN
SET DA=ICIEN
SET IENS=$$IENS^DILF(.DA)
+47 SET ICD9=$$GET1^DIQ(90680.21,IENS,.01,"E")
IF ICD9=""
QUIT
+48 SET ICDTP=$$GET1^DIQ(90680.21,IENS,.02,"I")
IF ICDTP'=1
QUIT
+49 SET ICD=ICD_$SELECT(ICD]"":";",1:"")_ICD9
End DoDot:3
+50 IF ICD=""
SET ICD=".9999"
+51 ;
+52 SET II=II+1
SET @DATA@(II)=IEN_U_TRM_U_FSPNM_U_CONC_U_PIP_U_ICD_$CHAR(30)
End DoDot:2
End DoDot:1
+53 ;
+54 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+55 QUIT
+56 ;
PICK(DATA,PLIEN,DFN) ;EP - BJPN GET PICK LIST
+1 ;
+2 ;This RPC returns entries from the BGO SNOMED PREFERENCES file (#90362.34).
+3 ;It will return all SNOMED entries for a particular Pick List Entry.
+4 ;
+5 ;If the DFN is supplied, it returns whether the patient has that Concept ID
+6 ;
+7 ;Input: PLIEN (Optional) - Pick List IEN (Master if null)
+8 ; DFN (Optional) - Patient DFN
+9 ;
+10 SET DFN=$GET(DFN)
+11 SET PLIEN=$GET(PLIEN)
+12 ;
+13 NEW UID,II,TRM,IEN,PRBLST
+14 ;
+15 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+16 SET DATA=$NAME(^TMP("BJPNPKL",UID))
+17 KILL @DATA
+18 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+19 SET II=0
+20 ;
+21 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPKL D UNWIND^%ZTER"
+22 ;
+23 SET @DATA@(II)="T00025DESC_ID^T00150SNOMED_TERM^T00250FULL_NAME^T00025CONCEPT_ID^I00010FREQ^T00010PIP^T00010ICD"
+24 SET @DATA@(II)=@DATA@(II)_"^T00001DISABLE^T00020DEF_STS^T00001CLASS^T00040GROUP^T00001PROMPT_LATERALITY"_$CHAR(30)
+25 ;
+26 ;First get a list of the current PIP items
+27 IF DFN]""
Begin DoDot:1
+28 NEW PRBIEN
+29 SET PRBIEN=""
FOR
SET PRBIEN=$ORDER(^BJPNPL("F",DFN,PRBIEN))
IF PRBIEN=""
QUIT
Begin DoDot:2
+30 NEW BPIEN
+31 SET BPIEN=""
FOR
SET BPIEN=$ORDER(^BJPNPL("F",DFN,PRBIEN,BPIEN))
IF BPIEN=""
QUIT
Begin DoDot:3
+32 NEW DEL,CONCID,DESCID
+33 ;
+34 ;Skip deletes
+35 ;PIP Delete
SET DEL=$$GET1^DIQ(90680.01,BPIEN_",",2.01,"I")
IF DEL]""
QUIT
+36 ;IPL Delete
SET DEL=$$GET1^DIQ(9000011,PRBIEN_",",2.02,"I")
IF DEL]""
Begin DoDot:4
+37 ;
+38 ;If deleted on IPL, need to delete in PIP
+39 NEW BJPNUPD,ERROR
+40 ;Deleted By
SET BJPNUPD(90680.01,BPIEN_",",2.01)=$$GET1^DIQ(9000011,PRBIEN_",",2.01,"I")
+41 ;Del Dt/Tm
SET BJPNUPD(90680.01,BPIEN_",",2.02)=$$GET1^DIQ(9000011,PRBIEN_",",2.02,"I")
+42 ;Del Rsn
SET BJPNUPD(90680.01,BPIEN_",",2.03)=$$GET1^DIQ(9000011,PRBIEN_",",2.03,"I")
+43 ;Del Other
SET BJPNUPD(90680.01,BPIEN_",",2.04)=$$GET1^DIQ(9000011,PRBIEN_",",2.04,"I")
+44 DO FILE^DIE("","BJPNUPD","ERROR")
End DoDot:4
QUIT
+45 ;
+46 ;Get the IPL Concept ID and Description ID
+47 SET CONCID=$$GET1^DIQ(9000011,PRBIEN_",",80001,"I")
IF CONCID=""
QUIT
+48 SET DESCID=$$GET1^DIQ(9000011,PRBIEN_",",80002,"I")
IF DESCID=""
QUIT
+49 ;
+50 ;Save the problem entry into array
+51 SET PRBLST(CONCID)=DESCID
End DoDot:3
End DoDot:2
End DoDot:1
+52 ;
+53 ;Process list passed in
+54 IF +PLIEN
DO LIST(+PLIEN,.PK,0)
+55 ;
+56 ;Process all lists
+57 IF 'PLIEN
Begin DoDot:1
+58 NEW PLIEN,PK
+59 SET PLIEN=0
FOR
SET PLIEN=$ORDER(^BGOSNOPR(PLIEN))
IF 'PLIEN
QUIT
Begin DoDot:2
+60 ;
+61 ;Filter out non-PIP pick lists
+62 IF '$$GET1^DIQ(90362.34,PLIEN_",",.09,"I")
QUIT
+63 ;
+64 ;Assemble the list
+65 DO LIST(+PLIEN,.PK,1)
End DoDot:2
End DoDot:1
+66 ;.. NEW CTIEN,SMDSTR
+67 ;.. S CTIEN=0 F S CTIEN=$O(^BGOSNOPR(+PLIEN,1,CTIEN)) Q:'CTIEN D
+68 ;... NEW CONCID,DESC,DESCTM,DA,IENS,FREQ,FNAME,ICD,PIP,DISABLE
+69 ;... S DA(1)=+PLIEN,DA=CTIEN,IENS=$$IENS^DILF(.DA)
+70 ;... S DESC=$$GET1^DIQ(90362.342,IENS,".02","I") Q:DESC=""
+71 ;... ;
+72 ;... ;Quit if already set
+73 ;... Q:$D(PK(DESC))
+74 ;... ;
+75 ;... S CONCID=$$GET1^DIQ(90362.342,IENS,".01","I") Q:CONCID=""
+76 ;... S DESCTM=$$GET1^DIQ(90362.342,IENS,"6","I") Q:DESCTM=""
+77 ;... S FREQ=$$GET1^DIQ(90362.342,IENS,".03","I") S:FREQ="" FREQ=0
+78 ;... S SMDSTR=$$CONC^BSTSAPI(CONCID_"^^"_DT_"^1")
+79 ;... S FNAME=$P(SMDSTR,U,2)
+80 ;... S ICD=$P(SMDSTR,U,5)
+81 ;... ;
+82 ;... ;Code on PIP?
+83 ;... S PIP="N",DISABLE=""
+84 ;... I DFN]"" D
+85 ;.... Q:'$D(PRBLST(CONCID))
+86 ;.... ;
+87 ;.... ;Mark as on PIP
+88 ;.... S PIP="Y"
+89 ;.... ;
+90 ;.... ;Disable if not the same synonym
+91 ;.... I DESC'=PRBLST(CONCID) S DISABLE="Y"
+92 ;... ;
+93 ;... ;Save the entry
+94 ;... S II=II+1,@DATA@(II)=DESC_U_DESCTM_U_FNAME_U_CONCID_U_FREQ_U_PIP_U_ICD_U_DISABLE_U_STS_U_CLASS_U_GROUP_U_LAT_$C(30)
+95 ;... ;
+96 ;... ;Flag entry so it will only be sent once
+97 ;... S PK(DESC)=""
+98 ;
XPICK SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
+3 ;Now loop through BGO SNOMED PREFERENCES file (#90362.34) for the picklist and return each entry
LIST(PLIEN,PK,ALL) ;
+1 NEW CTIEN
+2 SET CTIEN=0
FOR
SET CTIEN=$ORDER(^BGOSNOPR(+PLIEN,1,CTIEN))
IF 'CTIEN
QUIT
Begin DoDot:1
+3 NEW CONCID,DESC,DESCTM,DA,IENS,FREQ,FNAME,ICD,PIP,DISABLE,STS,CLASS,GROUP,LAT,BGON0,BGON1,CSTS,CRSLT,IIEN
+4 ;BJPN*2.0*7;Since picklists are so large avoid FileMan calls
+5 ;S DA(1)=+PLIEN,DA=CTIEN,IENS=$$IENS^DILF(.DA)
+6 ;S DESC=$$GET1^DIQ(90362.342,IENS,".02","I") Q:DESC=""
+7 ;S CONCID=$$GET1^DIQ(90362.342,IENS,".01","I") Q:CONCID=""
+8 ;S DESCTM=$$GET1^DIQ(90362.342,IENS,"6","I") Q:DESCTM=""
+9 ;S FREQ=$$GET1^DIQ(90362.342,IENS,".03","I") S:FREQ="" FREQ=0
+10 ;S SMDSTR=$$CONC^BSTSAPI(CONCID_"^^"_DT_"^1")
+11 ;S FNAME=$P(SMDSTR,U,2)
+12 ;S ICD=$P(SMDSTR,U,5)
+13 SET BGON0=$GET(^BGOSNOPR(+PLIEN,1,CTIEN,0))
+14 SET BGON1=$GET(^BGOSNOPR(+PLIEN,1,CTIEN,1))
+15 SET DESC=$PIECE(BGON0,U,2)
IF DESC=""
QUIT
+16 SET CONCID=$PIECE(BGON0,U,1)
IF CONCID=""
QUIT
+17 SET FREQ=$PIECE(BGON0,U,3)
IF FREQ=""
SET FREQ=0
+18 SET GROUP=$PIECE(BGON1,U,2)
+19 ;
+20 ;If show all do not use groups
+21 IF ALL
SET GROUP=""
+22 ;
+23 IF ALL
IF $DATA(PK(DESC))
QUIT
+24 ;
+25 ;Call BSTS to get needed information
+26 SET CSTS=$$DSCLKP^BSTSAPI("CRSLT",DESC)
+27 ;
+28 ;FSN
SET FNAME=$GET(CRSLT(1,"FSN","TRM"))
+29 ;ICD
SET IIEN=0
SET ICD=""
FOR
SET IIEN=$ORDER(CRSLT(1,"ICD",IIEN))
IF 'IIEN
QUIT
SET ICD=ICD_$SELECT(ICD]"":";",1:"")_$GET(CRSLT(1,"ICD",IIEN,"COD"))
+30 SET DESCTM=$GET(CRSLT(1,"PRB","TRM"))
+31 SET LAT=$GET(CRSLT(1,"LAT"))
SET LAT=$SELECT(LAT=1:"Y",1:"")
+32 ;
+33 ;Retrieve the default status
+34 ;Cannot use FileMan to retrieve the information because of a bug in the code in the EHR Pick List
+35 ;save logic that is saving the values incorrectly
+36 SET CLASS=""
SET STS=$PIECE(BGON0,U,6)
+37 ;Handle bug in EHR picklist code
IF STS="Personal History"
SET STS="P"
+38 IF STS="P"
SET CLASS="P"
+39 ;
+40 ;Custom code to account for EHR bug
+41 SET STS=$SELECT(STS="A":"Chronic",STS="S":"Sub-acute",STS="I":"Inactive",STS="E":"Episodic",STS="O":"Social/Environmental",STS="P":"Personal History",STS="R":"Admin",1:"Episodic")
+42 ;
+43 ;For show all use default status
+44 IF ALL
SET STS=$GET(CRSLT(1,"STS"))
+45 ;
+46 ;Code on PIP?
+47 SET PIP=""
SET DISABLE=""
+48 IF DFN]""
Begin DoDot:2
+49 IF '$DATA(PRBLST(CONCID))
QUIT
+50 ;
+51 ;Mark as on PIP
+52 SET PIP="On PIP"
+53 ;
+54 ;Disable if not the same synonym
+55 IF DESC'=PRBLST(CONCID)
SET DISABLE="Y"
End DoDot:2
+56 ;
+57 ;Save the entry
+58 SET II=II+1
SET @DATA@(II)=DESC_U_DESCTM_U_FNAME_U_CONCID_U_FREQ_U_PIP_U_ICD_U_DISABLE_U_STS_U_CLASS_U_GROUP_U_LAT_$CHAR(30)
+59 ;
+60 ;Record that it was found
+61 SET PK(DESC)=""
End DoDot:1
+62 ;
+63 QUIT
+64 ;
PPRV(VIEN) ;EP - Retrieve Visit Primary Provider
+1 ;
+2 NEW PPRV,IEN
+3 ;
+4 IF $GET(VIEN)=""
QUIT ""
+5 ;
+6 SET (PPRV,IEN)=""
FOR
SET IEN=$ORDER(^AUPNVPRV("AD",VIEN,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+7 NEW PTYPE
+8 SET PTYPE=$$GET1^DIQ(9000010.06,IEN_",",.04,"I")
IF PTYPE'="P"
QUIT
+9 SET PPRV=$$GET1^DIQ(9000010.06,IEN_",",.01,"I")
End DoDot:1
IF PPRV]""
QUIT
+10 QUIT PPRV
+11 ;
DEL(DATA,VIEN,DESCID,DCODE,DRSN,IPLDEL) ;BJPN PICK LIST PRB DELETE
+1 ;
+2 ;Delete prenatal problem from PIP
+3 ;
+4 ;Input:
+5 ; VIEN - Visit IEN
+6 ; DESCID - Description Id of Problem to Remove
+7 ; DCODE - Delete Code
+8 ; DRSN - Delete Reason (if Other)
+9 ; IPLDEL - Delete IPL entry
+10 ;
+11 NEW UID,II,%,DFN,CONCID,PRBIEN,PIPIEN,RSLT
+12 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+13 SET DATA=$NAME(^TMP("BJPNPKL",UID))
+14 KILL @DATA
+15 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+16 ;
+17 SET II=0
+18 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPKL D UNWIND^%ZTER"
+19 ;
+20 SET @DATA@(II)="T00010RESULT^T00150ERROR_MESSAGE"_$CHAR(30)
+21 ;
+22 ;Input validation
+23 IF $GET(VIEN)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING VISIT IEN"_$CHAR(30)
GOTO XDEL
+24 IF $GET(DESCID)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING Description ID"_$CHAR(30)
GOTO XDEL
+25 SET DCODE=$GET(DCODE,"")
SET DRSN=$GET(DRSN,"")
+26 SET DFN=$$GET1^DIQ(9000010,VIEN_",",".05","I")
IF DFN=""
SET II=II+1
SET @DATA@(II)="-1^INVALID DFN"_$CHAR(30)
GOTO XDEL
+27 ;
+28 ;Get the Concept ID
+29 SET CONCID=$PIECE($$DESC^BSTSAPI(DESCID_"^^1"),U)
IF CONCID=""
SET II=II+1
SET @DATA@(II)="-1^COULD NOT FIND CONCEPT ID"_$CHAR(30)
GOTO XDEL
+30 ;
+31 ;Locate the PIP entry
+32 SET (PIPIEN,PRBIEN)=""
+33 FOR
SET PRBIEN=$ORDER(^BJPNPL("F",DFN,PRBIEN))
IF PRBIEN=""
QUIT
Begin DoDot:1
+34 NEW BPIEN,IPLCNC,DEL
+35 ;
+36 ;Skip deletes
+37 ;IPL Delete
SET DEL=$$GET1^DIQ(9000011,PRBIEN_",",2.02,"I")
IF DEL]""
QUIT
+38 ;
+39 ;Get the Concept Id of the IPL entry - Look for a match
+40 SET IPLCNC=$$GET1^DIQ(9000011,PRBIEN_",",80001,"I")
IF IPLCNC=""
QUIT
+41 IF IPLCNC'=CONCID
QUIT
+42 ;
+43 ;Verify the PIPIEN is correct
+44 SET BPIEN=""
FOR
SET BPIEN=$ORDER(^BJPNPL("F",DFN,PRBIEN,BPIEN))
IF BPIEN=""
QUIT
Begin DoDot:2
+45 NEW DEL
+46 ;
+47 ;Skip deletes
+48 SET DEL=$$GET1^DIQ(90680.01,BPIEN_",",2.01,"I")
IF DEL]""
QUIT
+49 ;
+50 ;Set the PIPIEN
+51 SET PIPIEN=BPIEN
End DoDot:2
End DoDot:1
IF PIPIEN
QUIT
+52 ;
+53 ;Quit if no PIP entry found
+54 IF ($GET(PIPIEN)="")!($GET(PRBIEN)="")
SET II=II+1
SET @DATA@(II)="-1^COULD NOT FIND PROBLEM ON PIP"_$CHAR(30)
GOTO XDEL
+55 ;
+56 ;Make the call to delete
+57 DO DEL^BJPNCPIP("",VIEN,PIPIEN,DCODE,DRSN,$GET(IPLDEL))
+58 ;
+59 ;Get the result
+60 SET RSLT=$PIECE($GET(^TMP("BJPNCPIP",UID,1)),$CHAR(30))
+61 SET II=II+1
SET @DATA@(II)=$PIECE(RSLT,U)_U_$PIECE(RSLT,U,2)_$CHAR(30)
+62 ;
+63 ;Broadcast update
+64 ;BJPN*2.0*7;Removed PPL - This call isn't used but made the fix just in case
+65 DO FIREEV^BJPNPDET("","PCC."_DFN_".PPL")
+66 DO FIREEV^BJPNPDET("","PCC."_DFN_".PIP")
+67 ;
XDEL SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+5 QUIT
