Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BJPNPKL

BJPNPKL.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  Q
  1.  ;
  1. LST(DATA,FAKE) ;EP - BJPN GET PICK LISTS
  1.  ;
  1.  ;This RPC returns top level entries from the BGO SNOMED PREFERENCES file (#90362.34)
  1.  ;
  1.  NEW UID,II,IEN
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BJPNPKL",UID))
  1.  K @DATA
  1.  I $G(DT)=""!($G(U)="") D DT^DICRW
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPKL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
  1.  ;
  1.  S @DATA@(II)="I00010HIDDEN_PLIEN^T00030PICK_LISTS^T00001SET_POV"_$C(30)
  1.  ;
  1.  S IEN=0 F  S IEN=$O(^BGOSNOPR(IEN)) Q:'IEN  D
  1.  . ;
  1.  . NEW NAME,POV
  1.  . ;
  1.  . ;Only include PIP Pick Lists
  1.  . I '$$GET1^DIQ(90362.34,IEN_",",".09","I") Q
  1.  . ;
  1.  . ;Skip if it doesn't have any entries
  1.  . I '+$O(^BGOSNOPR(IEN,1,0)) Q
  1.  . ;Name
  1.  . S NAME=$$GET1^DIQ(90362.34,IEN_",",".01","E") Q:NAME=""
  1.  . ;
  1.  . ;Return whether to allow POV Set
  1.  . S POV=$$GET1^DIQ(90362.34,IEN_",","1.1","I")
  1.  . ;
  1.  . S II=II+1,@DATA@(II)=IEN_U_NAME_U_POV_$C(30)
  1.  ;
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  ;
  1.  Q
  1.  ;
  1. SNO(DATA,DFN) ;EP - BJPN GET SNOMED TERMS
  1.  ;
  1.  ;This RPC returns entries from the BJPN SNOMED TERMS file (#90680.02)
  1.  ;If the DFN is supplied, it returns whether the patient has that problem
  1.  ;on their PIP
  1.  ;
  1.  ;Input: DFN (Optional) - Patient DFN
  1.  ;
  1.  S DFN=$G(DFN)
  1.  ;
  1.  NEW UID,II,PSTS,RFEDD,PREDD,ICD
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BJPNPRL",UID))
  1.  K @DATA
  1.  I $G(DT)=""!($G(U)="") D DT^DICRW
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPKL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
  1.  ;
  1.  S @DATA@(II)="I00010HIDDEN_PKIEN^T00150SNOMED_TERM^T00250FULL_NAME^T00025CONCEPT_ID^T00001PIP^T00010ICD"_$C(30)
  1.  ;
  1.  S TRM="" F  S TRM=$O(^BJPN(90680.02,"C",TRM)) Q:TRM=""  D
  1.  . S IEN="" F  S IEN=$O(^BJPN(90680.02,"C",TRM,IEN)) Q:IEN=""  D
  1.  .. NEW TRM,FSPNM,CAT,CIEN,IENS,CONC,FREQ,PIP,PLIEN,ICIEN
  1.  .. ;
  1.  .. ;SNOMED TERM
  1.  .. S TRM=$$GET1^DIQ(90680.02,IEN_",",.02,"E") Q:TRM=""
  1.  .. ;
  1.  .. ;FULLY SPECIFIED NAME
  1.  .. S FSPNM=$$GET1^DIQ(90680.02,IEN_",",3,"E")
  1.  .. ;
  1.  .. ;CONCEPT ID
  1.  .. S CONC=$$GET1^DIQ(90680.02,IEN_",",.07,"E") Q:CONC=""
  1.  .. ;
  1.  .. ;Code on Problem List
  1.  .. S PIP="N"
  1.  .. I DFN]"" S PLIEN="" F  S PLIEN=$O(^BJPNPL("AC",DFN,IEN,PLIEN)) Q:PLIEN=""  D
  1.  ... NEW DEL
  1.  ... I $$GET1^DIQ(90680.01,PLIEN_",",2.01,"I")]"" Q
  1.  ... S PIP="Y"
  1.  .. ;
  1.  .. ;Pull the ICD-9
  1.  .. S ICD=""
  1.  .. S ICIEN=0 F  S ICIEN=$O(^BJPN(90680.02,IEN,1,ICIEN)) Q:'ICIEN  D
  1.  ... ;
  1.  ... NEW ICD9,ICDTP,DA,IENS
  1.  ... S DA(1)=IEN,DA=ICIEN,IENS=$$IENS^DILF(.DA)
  1.  ... S ICD9=$$GET1^DIQ(90680.21,IENS,.01,"E") Q:ICD9=""
  1.  ... S ICDTP=$$GET1^DIQ(90680.21,IENS,.02,"I") I ICDTP'=1 Q
  1.  ... S ICD=ICD_$S(ICD]"":";",1:"")_ICD9
  1.  .. S:ICD="" ICD=".9999"
  1.  .. ;
  1.  .. S II=II+1,@DATA@(II)=IEN_U_TRM_U_FSPNM_U_CONC_U_PIP_U_ICD_$C(30)
  1.  ;
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. PICK(DATA,PLIEN,DFN) ;EP - BJPN GET PICK LIST
  1.  ;
  1.  ;This RPC returns entries from the BGO SNOMED PREFERENCES file (#90362.34).
  1.  ;It will return all SNOMED entries for a particular Pick List Entry.
  1.  ;
  1.  ;If the DFN is supplied, it returns whether the patient has that Concept ID
  1.  ;
  1.  ;Input: PLIEN (Optional) - Pick List IEN (Master if null)
  1.  ;       DFN (Optional) - Patient DFN
  1.  ;
  1.  S DFN=$G(DFN)
  1.  S PLIEN=$G(PLIEN)
  1.  ;
  1.  NEW UID,II,TRM,IEN,PRBLST
  1.  ;
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BJPNPKL",UID))
  1.  K @DATA
  1.  I $G(DT)=""!($G(U)="") D DT^DICRW
  1.  S II=0
  1.  ;
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPKL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
  1.  ;
  1.  S @DATA@(II)="T00025DESC_ID^T00150SNOMED_TERM^T00250FULL_NAME^T00025CONCEPT_ID^I00010FREQ^T00010PIP^T00010ICD"
  1.  S @DATA@(II)=@DATA@(II)_"^T00001DISABLE^T00020DEF_STS^T00001CLASS^T00040GROUP^T00001PROMPT_LATERALITY"_$C(30)
  1.  ;
  1.  ;First get a list of the current PIP items
  1.  I DFN]"" D
  1.  . NEW PRBIEN
  1.  . S PRBIEN="" F  S PRBIEN=$O(^BJPNPL("F",DFN,PRBIEN)) Q:PRBIEN=""  D
  1.  .. NEW BPIEN
  1.  .. S BPIEN="" F  S BPIEN=$O(^BJPNPL("F",DFN,PRBIEN,BPIEN)) Q:BPIEN=""  D
  1.  ... NEW DEL,CONCID,DESCID
  1.  ... ;
  1.  ... ;Skip deletes
  1.  ... S DEL=$$GET1^DIQ(90680.01,BPIEN_",",2.01,"I") Q:DEL]""  ;PIP Delete
  1.  ... S DEL=$$GET1^DIQ(9000011,PRBIEN_",",2.02,"I") I DEL]"" D  Q  ;IPL Delete
  1.  .... ;
  1.  .... ;If deleted on IPL, need to delete in PIP
  1.  .... NEW BJPNUPD,ERROR
  1.  .... S BJPNUPD(90680.01,BPIEN_",",2.01)=$$GET1^DIQ(9000011,PRBIEN_",",2.01,"I") ;Deleted By
  1.  .... S BJPNUPD(90680.01,BPIEN_",",2.02)=$$GET1^DIQ(9000011,PRBIEN_",",2.02,"I") ;Del Dt/Tm
  1.  .... S BJPNUPD(90680.01,BPIEN_",",2.03)=$$GET1^DIQ(9000011,PRBIEN_",",2.03,"I") ;Del Rsn
  1.  .... S BJPNUPD(90680.01,BPIEN_",",2.04)=$$GET1^DIQ(9000011,PRBIEN_",",2.04,"I") ;Del Other
  1.  .... D FILE^DIE("","BJPNUPD","ERROR")
  1.  ... ;
  1.  ... ;Get the IPL Concept ID and Description ID
  1.  ... S CONCID=$$GET1^DIQ(9000011,PRBIEN_",",80001,"I") Q:CONCID=""
  1.  ... S DESCID=$$GET1^DIQ(9000011,PRBIEN_",",80002,"I") Q:DESCID=""
  1.  ... ;
  1.  ... ;Save the problem entry into array
  1.  ... S PRBLST(CONCID)=DESCID
  1.  ;
  1.  ;Process list passed in
  1.  I +PLIEN D LIST(+PLIEN,.PK,0)
  1.  ;
  1.  ;Process all lists
  1.  I 'PLIEN D
  1.  . NEW PLIEN,PK
  1.  . S PLIEN=0 F  S PLIEN=$O(^BGOSNOPR(PLIEN)) Q:'PLIEN  D
  1.  .. ;
  1.  .. ;Filter out non-PIP pick lists
  1.  .. Q:'$$GET1^DIQ(90362.34,PLIEN_",",.09,"I")
  1.  .. ;
  1.  .. ;Assemble the list
  1.  .. D LIST(+PLIEN,.PK,1)
  1.  ;.. NEW CTIEN,SMDSTR
  1.  ;.. S CTIEN=0 F  S CTIEN=$O(^BGOSNOPR(+PLIEN,1,CTIEN)) Q:'CTIEN  D
  1.  ;... NEW CONCID,DESC,DESCTM,DA,IENS,FREQ,FNAME,ICD,PIP,DISABLE
  1.  ;... S DA(1)=+PLIEN,DA=CTIEN,IENS=$$IENS^DILF(.DA)
  1.  ;... S DESC=$$GET1^DIQ(90362.342,IENS,".02","I") Q:DESC=""
  1.  ;... ;
  1.  ;... ;Quit if already set
  1.  ;... Q:$D(PK(DESC))
  1.  ;... ;
  1.  ;... S CONCID=$$GET1^DIQ(90362.342,IENS,".01","I") Q:CONCID=""
  1.  ;... S DESCTM=$$GET1^DIQ(90362.342,IENS,"6","I") Q:DESCTM=""
  1.  ;... S FREQ=$$GET1^DIQ(90362.342,IENS,".03","I") S:FREQ="" FREQ=0
  1.  ;... S SMDSTR=$$CONC^BSTSAPI(CONCID_"^^"_DT_"^1")
  1.  ;... S FNAME=$P(SMDSTR,U,2)
  1.  ;... S ICD=$P(SMDSTR,U,5)
  1.  ;... ;
  1.  ;... ;Code on PIP?
  1.  ;... S PIP="N",DISABLE=""
  1.  ;... I DFN]"" D
  1.  ;.... Q:'$D(PRBLST(CONCID))
  1.  ;.... ;
  1.  ;.... ;Mark as on PIP
  1.  ;.... S PIP="Y"
  1.  ;.... ;
  1.  ;.... ;Disable if not the same synonym
  1.  ;.... I DESC'=PRBLST(CONCID) S DISABLE="Y"
  1.  ;... ;
  1.  ;... ;Save the entry
  1.  ;... 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)
  1.  ;... ;
  1.  ;... ;Flag entry so it will only be sent once
  1.  ;... S PK(DESC)=""
  1.  ;
  1. XPICK S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1.  ;Now loop through BGO SNOMED PREFERENCES file (#90362.34) for the picklist and return each entry
  1. LIST(PLIEN,PK,ALL) ;
  1.  NEW CTIEN
  1.  S CTIEN=0 F  S CTIEN=$O(^BGOSNOPR(+PLIEN,1,CTIEN)) Q:'CTIEN  D
  1.  . NEW CONCID,DESC,DESCTM,DA,IENS,FREQ,FNAME,ICD,PIP,DISABLE,STS,CLASS,GROUP,LAT,BGON0,BGON1,CSTS,CRSLT,IIEN
  1.  . ;BJPN*2.0*7;Since picklists are so large avoid FileMan calls
  1.  . ;S DA(1)=+PLIEN,DA=CTIEN,IENS=$$IENS^DILF(.DA)
  1.  . ;S DESC=$$GET1^DIQ(90362.342,IENS,".02","I") Q:DESC=""
  1.  . ;S CONCID=$$GET1^DIQ(90362.342,IENS,".01","I") Q:CONCID=""
  1.  . ;S DESCTM=$$GET1^DIQ(90362.342,IENS,"6","I") Q:DESCTM=""
  1.  . ;S FREQ=$$GET1^DIQ(90362.342,IENS,".03","I") S:FREQ="" FREQ=0
  1.  . ;S SMDSTR=$$CONC^BSTSAPI(CONCID_"^^"_DT_"^1")
  1.  . ;S FNAME=$P(SMDSTR,U,2)
  1.  . ;S ICD=$P(SMDSTR,U,5)
  1.  . S BGON0=$G(^BGOSNOPR(+PLIEN,1,CTIEN,0))
  1.  . S BGON1=$G(^BGOSNOPR(+PLIEN,1,CTIEN,1))
  1.  . S DESC=$P(BGON0,U,2) Q:DESC=""
  1.  . S CONCID=$P(BGON0,U,1) Q:CONCID=""
  1.  . S FREQ=$P(BGON0,U,3) S:FREQ="" FREQ=0
  1.  . S GROUP=$P(BGON1,U,2)
  1.  . ;
  1.  . ;If show all do not use groups
  1.  . I ALL S GROUP=""
  1.  . ;
  1.  . I ALL Q:$D(PK(DESC))
  1.  . ;
  1.  . ;Call BSTS to get needed information
  1.  . S CSTS=$$DSCLKP^BSTSAPI("CRSLT",DESC)
  1.  . ;
  1.  . S FNAME=$G(CRSLT(1,"FSN","TRM")) ;FSN
  1.  . 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
  1.  . S DESCTM=$G(CRSLT(1,"PRB","TRM"))
  1.  . S LAT=$G(CRSLT(1,"LAT")),LAT=$S(LAT=1:"Y",1:"")
  1.  . ;
  1.  . ;Retrieve the default status
  1.  . ;Cannot use FileMan to retrieve the information because of a bug in the code in the EHR Pick List
  1.  . ;save logic that is saving the values incorrectly
  1.  . S CLASS="",STS=$P(BGON0,U,6)
  1.  . S:STS="Personal History" STS="P"  ;Handle bug in EHR picklist code
  1.  . I STS="P" S CLASS="P"
  1.  . ;
  1.  . ;Custom code to account for EHR bug
  1.  . 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")
  1.  . ;
  1.  . ;For show all use default status
  1.  . I ALL S STS=$G(CRSLT(1,"STS"))
  1.  . ;
  1.  . ;Code on PIP?
  1.  . S PIP="",DISABLE=""
  1.  . I DFN]"" D
  1.  .. Q:'$D(PRBLST(CONCID))
  1.  .. ;
  1.  .. ;Mark as on PIP
  1.  .. S PIP="On PIP"
  1.  .. ;
  1.  .. ;Disable if not the same synonym
  1.  .. I DESC'=PRBLST(CONCID) S DISABLE="Y"
  1.  . ;
  1.  . ;Save the entry
  1.  . 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)
  1.  . ;
  1.  . ;Record that it was found
  1.  . S PK(DESC)=""
  1.  ;
  1.  Q
  1.  ;
  1. PPRV(VIEN) ;EP - Retrieve Visit Primary Provider
  1.  ;
  1.  NEW PPRV,IEN
  1.  ;
  1.  I $G(VIEN)="" Q ""
  1.  ;
  1.  S (PPRV,IEN)="" F  S IEN=$O(^AUPNVPRV("AD",VIEN,IEN)) Q:'IEN  D  Q:PPRV]""
  1.  . NEW PTYPE
  1.  . S PTYPE=$$GET1^DIQ(9000010.06,IEN_",",.04,"I") Q:PTYPE'="P"
  1.  . S PPRV=$$GET1^DIQ(9000010.06,IEN_",",.01,"I")
  1.  Q PPRV
  1.  ;
  1. DEL(DATA,VIEN,DESCID,DCODE,DRSN,IPLDEL) ;BJPN PICK LIST PRB DELETE
  1.  ;
  1.  ;Delete prenatal problem from PIP
  1.  ;
  1.  ;Input:
  1.  ; VIEN - Visit IEN
  1.  ; DESCID - Description Id of Problem to Remove
  1.  ; DCODE - Delete Code
  1.  ; DRSN - Delete Reason (if Other)
  1.  ; IPLDEL - Delete IPL entry
  1.  ;
  1.  NEW UID,II,%,DFN,CONCID,PRBIEN,PIPIEN,RSLT
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BJPNPKL",UID))
  1.  K @DATA
  1.  I $G(DT)=""!($G(U)="") D DT^DICRW
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPKL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
  1.  ;
  1.  S @DATA@(II)="T00010RESULT^T00150ERROR_MESSAGE"_$C(30)
  1.  ;
  1.  ;Input validation
  1.  I $G(VIEN)="" S II=II+1,@DATA@(II)="-1^MISSING VISIT IEN"_$C(30) G XDEL
  1.  I $G(DESCID)="" S II=II+1,@DATA@(II)="-1^MISSING Description ID"_$C(30) G XDEL
  1.  S DCODE=$G(DCODE,""),DRSN=$G(DRSN,"")
  1.  S DFN=$$GET1^DIQ(9000010,VIEN_",",".05","I") I DFN="" S II=II+1,@DATA@(II)="-1^INVALID DFN"_$C(30) G XDEL
  1.  ;
  1.  ;Get the Concept ID
  1.  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
  1.  ;
  1.  ;Locate the PIP entry
  1.  S (PIPIEN,PRBIEN)=""
  1.  F  S PRBIEN=$O(^BJPNPL("F",DFN,PRBIEN)) Q:PRBIEN=""  D  Q:PIPIEN
  1.  . NEW BPIEN,IPLCNC,DEL
  1.  . ;
  1.  . ;Skip deletes
  1.  . S DEL=$$GET1^DIQ(9000011,PRBIEN_",",2.02,"I") I DEL]"" Q  ;IPL Delete
  1.  . ;
  1.  . ;Get the Concept Id of the IPL entry - Look for a match
  1.  . S IPLCNC=$$GET1^DIQ(9000011,PRBIEN_",",80001,"I") Q:IPLCNC=""
  1.  . I IPLCNC'=CONCID Q
  1.  . ;
  1.  . ;Verify the PIPIEN is correct
  1.  . S BPIEN="" F  S BPIEN=$O(^BJPNPL("F",DFN,PRBIEN,BPIEN)) Q:BPIEN=""  D
  1.  .. NEW DEL
  1.  .. ;
  1.  .. ;Skip deletes
  1.  .. S DEL=$$GET1^DIQ(90680.01,BPIEN_",",2.01,"I") I DEL]"" Q
  1.  .. ;
  1.  .. ;Set the PIPIEN
  1.  .. S PIPIEN=BPIEN
  1.  ;
  1.  ;Quit if no PIP entry found
  1.  I ($G(PIPIEN)="")!($G(PRBIEN)="") S II=II+1,@DATA@(II)="-1^COULD NOT FIND PROBLEM ON PIP"_$C(30) G XDEL
  1.  ;
  1.  ;Make the call to delete
  1.  D DEL^BJPNCPIP("",VIEN,PIPIEN,DCODE,DRSN,$G(IPLDEL))
  1.  ;
  1.  ;Get the result
  1.  S RSLT=$P($G(^TMP("BJPNCPIP",UID,1)),$C(30))
  1.  S II=II+1,@DATA@(II)=$P(RSLT,U)_U_$P(RSLT,U,2)_$C(30)
  1.  ;
  1.  ;Broadcast update
  1.  ;BJPN*2.0*7;Removed PPL - This call isn't used but made the fix just in case
  1.  D FIREEV^BJPNPDET("","PCC."_DFN_".PPL")
  1.  D FIREEV^BJPNPDET("","PCC."_DFN_".PIP")
  1.  ;
  1. XDEL S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. ERR ;
  1.  D ^%ZTER
  1.  NEW Y,ERRDTM
  1.  S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q