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

BJPNPCHK.m

Go to the documentation of this file. 
  1. BJPNPCHK ;GDIT/HS/BEE-Prenatal Care Module Duplicate Problem Checking ; 08 May 2012  12:00 PM
  1.  ;;2.0;PRENATAL CARE MODULE;**7**;Feb 24, 2015;Build 53
  1.  ;
  1.  Q
  1.  ;
  1. PCHECK(DATA,DFN,CONCID,VIEN,DESCID,LAT,PRBIEN,PIPIEN) ;EP - BJPN CHECK FOR PROBLEM
  1.  ;
  1.  ;This RPC checks to see if a particular SNOMED CT/Laterality or its equivalent concept is on a patient's
  1.  ;PIP or IPL.
  1.  ;
  1.  ;Input parameter:
  1.  ;  DFN   - Patient DFN
  1.  ; CONCID - The Concept ID to lookup
  1.  ;   VIEN - Visit IEN
  1.  ; DESCID - Description Id (Required if CONCID is null)
  1.  ;    LAT - Laterality (Optional) - The internal attribute|laterality value
  1.  ; PRBIEN - The problem IEN of the problem being modified (if applicable)
  1.  ; PIPIEN - The PIP IEN of the problem being modified (if applicable)
  1.  ;
  1.  ;Input checks
  1.  S LAT=$G(LAT)
  1.  S PRBIEN=+$G(PRBIEN)
  1.  S PIPIEN=+$G(PIPIEN)
  1.  I $G(DFN)="" S BMXSEC="Missing patient DFN value" G XPCHECK
  1.  I $G(CONCID)="" S BMXSEC="Missing Concept ID" G XPCHECK
  1.  I $G(DESCID)="" S BMXSEC="Missing Description ID" G XPCHECK
  1.  I $G(VIEN)="" S BMXSEC="Missing VIEN value" G XPCHECK
  1.  I $G(DUZ(2))="" S BMXSEC="DUZ(2) is not properly defined" G XPCHECK
  1.  ;
  1.  NEW UID,II,NXTPRB,EQCN,CENT,ITYPE,TMP,TII,EXFND,PCNC,PDSC,PNXT,EXMNOPRB
  1.  ;
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BJPNPCHK",UID))
  1.  K @DATA
  1.  I $G(DT)=""!($G(U)="") D DT^DICRW
  1.  ;
  1.  ;Get current problem information
  1.  S (PCNC,PDSC,PNXT)="" I +PRBIEN D
  1.  . S PCNC=$$GET1^DIQ(9000011,PRBIEN_",",80001,"I")  ;Current concept id
  1.  . S PDSC=$$GET1^DIQ(9000011,PRBIEN_",",80002,"I")  ;Current description id
  1.  . S PNXT=$$GET1^DIQ(9000011,PRBIEN_",",.07,"I") ;Next Problem Value
  1.  ;
  1.  S (II,TII)=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPCHK D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
  1.  ;
  1.  ;Define Header
  1.  S @DATA@(0)="T00030CONC_ID^T00025INT_LATERALITY^T00030DESC_ID^T00500DESC_TERM^I00010PRBIEN^I00010PIPIEN^T00001PATIENT_TYPE"
  1.  S @DATA@(0)=@DATA@(0)_"^T00050NEXT_PRB^T00001EXACT_MATCH^T00040EXT_LATERALITY^T00015ICD^T00030STATUS"
  1.  S @DATA@(0)=@DATA@(0)_"^T00001PROMPT_LATERALITY^T00500PROVIDER_NARRATIVE^T00001LATERALIZED_CONCEPT"_$C(30)
  1.  ;
  1.  ;Call BSTS to find the equivalent concepts
  1.  D EQUIV^BSTSAPI("EQCN",CONCID_U_LAT)
  1.  I $O(EQCN(""))="" G XPCHECK
  1.  ;
  1.  ;Get the next problem number
  1.  D
  1.  . NEW RET
  1.  . D NEXTID^BGOPROB(.RET,DFN)
  1.  . S NXTPRB=RET
  1.  ;
  1.  ;Get the visit type
  1.  S ITYPE=$$GET1^DIQ(9000010,VIEN_",",.07,"I")
  1.  S ITYPE=$S(ITYPE="H":"H",1:"A")
  1.  ;
  1.  ;Now loop through the returned values and look for them
  1.  S (EXMNOPRB,EXFND)=0,CENT="" F  S CENT=$O(EQCN(CENT)) Q:CENT=""  D
  1.  . ;
  1.  . NEW ENOD,ECNC,FND,ELAT,F,EEXT,LATCNC
  1.  . ;
  1.  . ;Pull the returned record
  1.  . S ENOD=EQCN(CENT) Q:$TR(ENOD,U)=""
  1.  . S ECNC=$P(ENOD,U)
  1.  . S ELAT=$P(ENOD,U,2)
  1.  . S EEXT=$P(ENOD,U,3)
  1.  . S FND=0
  1.  . ;
  1.  . ;For first concept return laterality
  1.  . S LATCNC="" I CENT=1,$P(ENOD,U,4)=1 S LATCNC="Y"
  1.  . ;
  1.  . ;Have laterality - Look in "ASLT" cross reference
  1.  . I $TR(ELAT,"|")]"" D
  1.  .. ;
  1.  .. NEW PIEN
  1.  .. S PIEN="" F  S PIEN=$O(^AUPNPROB("ASLT",DFN,ECNC,ELAT,PIEN)) Q:PIEN=""  S F=$$GPROB(.TMP,PIEN,ENOD,ITYPE,.EXFND,.TII,LATCNC) S:F FND=1
  1.  . ;
  1.  . ;No laterality - Look in "APCT" cross reference
  1.  . I $TR(ELAT,"|")="" D
  1.  .. ;
  1.  .. NEW PIEN
  1.  .. S PIEN="" F  S PIEN=$O(^AUPNPROB("APCT",DFN,ECNC,PIEN)) Q:PIEN=""  S F=$$GPROB(.TMP,PIEN,ENOD,ITYPE,.EXFND,.TII,LATCNC) S:F FND=1
  1.  . ;
  1.  . ;If not found, return entry
  1.  . I FND=0,CONCID=ECNC,LAT=ELAT D
  1.  .. ;
  1.  .. NEW PDST,EXLAT,ICD,DSTS,DDATA,PRMLST,PMLT
  1.  .. S PRMLST="" I $P(ELAT,"|",2)]"" S PRMLST="LAT="_$P(ELAT,"|",2)
  1.  .. S DDATA=$$DESC^BSTSAPI(DESCID_"^^1^^^"_PRMLST)
  1.  .. S PDST=$P(DDATA,U,2)
  1.  .. ;
  1.  .. ;Get external laterality
  1.  .. S EXLAT="" I $TR(ELAT,"|")]"" S EXLAT=$$CVPARM^BSTSMAP1("LAT",$P(ELAT,"|"))_"|"_$$CVPARM^BSTSMAP1("LAT",$P(ELAT,"|",2))
  1.  .. ;
  1.  .. ;Get ICD, default status and prompt laterality
  1.  .. S ICD=$P(DDATA,U,3)
  1.  .. S DSTS=$P(DDATA,U,7)
  1.  .. S PMLT=$P(DDATA,U,6)
  1.  .. ; 
  1.  .. ;No match found - log that entry can be used
  1.  .. S TII=$G(TII)+1,TMP(TII)=ECNC_U_ELAT_U_DESCID_U_PDST_U_0_U_0_U_ITYPE_U_NXTPRB_U_EEXT_U_EXLAT_U_ICD_U_DSTS_U_$S(PMLT:"Y",1:"")_U_U_LATCNC
  1.  .. I EEXT S EXMNOPRB=1  ;Track if an exact match
  1.  ;
  1.  ;Loop through results - eliminate others if exact match found
  1.  S TII="" F  S TII=$O(TMP(TII)) Q:'TII  D
  1.  . ;
  1.  . NEW TNODE
  1.  . S TNODE=TMP(TII)
  1.  . ;
  1.  . ;Special logic for exact match found on IPL - Only include it
  1.  . I $D(TMP("EXACT")) D  Q
  1.  .. ;
  1.  .. NEW EXNODE
  1.  .. ;
  1.  .. ;Get the exact match
  1.  .. S EXNODE=TMP(TMP("EXACT"))
  1.  .. ;
  1.  .. ;If not an exact match do not include
  1.  .. I '$P(TNODE,U,9) Q
  1.  .. ;
  1.  .. ;Passed in problem is the same as the exact match problem
  1.  .. ;
  1.  .. I +PRBIEN,PRBIEN=$P(EXNODE,U,5) D  Q
  1.  ... ;
  1.  ... ;The user switched to the equivalent concept - update original
  1.  ... ;passed in problem info with new SNOMED/laterality information
  1.  ... I $P(TNODE,U,9)=1,$P(TNODE,U,5)=0 D  Q
  1.  .... NEW I
  1.  .... S EXNODE=TMP(TMP("EXACT"))
  1.  .... F I=5:1:9 S $P(TNODE,U,I)=$P(EXNODE,U,I)
  1.  .... S II=II+1,@DATA@(II)=TNODE_$C(30)
  1.  ... ;
  1.  ... ;The user picked the same concept - return original
  1.  ... I $P(TNODE,U,9)=1,TMP("EXACT")=TII D  Q
  1.  .... Q:CONCID'=$P(TNODE,U)  ;Concept not the same
  1.  .... Q:LAT'=$P(TNODE,U,2)  ;Laterality not the same
  1.  .... S TNODE=TMP(TMP("EXACT"))
  1.  .... S II=II+1,@DATA@(II)=TNODE_$C(30)
  1.  .. ;
  1.  .. ;No passed in problem or not a match with exact
  1.  .. ;
  1.  .. ;If exact match, allow - GUI will utilize IPL problem returned
  1.  .. I TMP("EXACT")=TII D  Q
  1.  ... S TNODE=TMP(TMP("EXACT"))_$C(30)
  1.  ... S II=II+1,@DATA@(II)=TNODE
  1.  . ;
  1.  . ;Problem edit - changed SNOMED and it isn't a match on IPL
  1.  . ;update entry with passed in problem information
  1.  . I +PRBIEN,$P(TNODE,U,5)="" D  Q
  1.  .. S $P(TNODE,U,5)=PRBIEN
  1.  .. S $P(TNODE,U,6)=PIPIEN
  1.  .. S $P(TNODE,U,7)=ITYPE
  1.  .. S $P(TNODE,U,8)=PNXT
  1.  .. S II=II+1,@DATA@(II)=TNODE_$C(30)
  1.  . ;
  1.  . ;Not an exact match on IPL, exact found by BSTS and edit fill entries
  1.  . I +PIPIEN,EXMNOPRB D  Q   ;Edit and an exact match was saved
  1.  .. I $P(TNODE,U,9) D  ;This is the exact match
  1.  ... S $P(TNODE,U,5)=PRBIEN
  1.  ... S $P(TNODE,U,6)=PIPIEN
  1.  ... S $P(TNODE,U,7)=ITYPE
  1.  ... S $P(TNODE,U,8)=PNXT
  1.  ... S II=II+1,@DATA@(II)=TNODE_$C(30)
  1.  . ;
  1.  . ;No exact matches - save related ones
  1.  . S II=II+1,@DATA@(II)=TNODE_$C(30)
  1.  ;
  1. XPCHECK S II=$G(II)+1,@DATA@(II)=$C(31)
  1.  ;
  1.  Q
  1.  ;
  1. GPROB(TMP,PIEN,ENOD,ITYPE,EXFND,TII,LATCNC) ;Set up return entry for problem
  1.  ;
  1.  I +$G(PIEN)=0 Q 0
  1.  ;
  1.  ;Skip deleted problems
  1.  I $$GET1^DIQ(9000011,PIEN_",",2.02,"I")]"" Q 0
  1.  ;
  1.  NEW PCNC,PDSC,PDST,PNXT,PIPIEN,PFND,PPIEN,EEXT,PLAT,EXLAT,ICD,DSTS,DDATA,PRMLST,PMLT,PNAR
  1.  ;
  1.  ;If matching concept id and no laterality passed in, filter out those with laterality
  1.  S PLAT=$$GET1^DIQ(9000011,PIEN_",",.22,"I") ;Laterality
  1.  I $P(ENOD,U,2)="",PLAT]"" Q 0
  1.  ;
  1.  S PCNC=$$GET1^DIQ(9000011,PIEN_",",80001,"I") ;Concept ID
  1.  S PDSC=$$GET1^DIQ(9000011,PIEN_",",80002,"I") ;Description ID
  1.  S PNAR=$$GET1^DIQ(9000011,PIEN_",",.05,"E")  ;Provider narrative
  1.  S PDST=$P($$DESC^BSTSAPI(PDSC_"^^1"),U,2) ;Description Term
  1.  S PNXT=$$GET1^DIQ(9000011,PIEN_",",.07,"I") ;Next Problem Value
  1.  S EEXT=$P(ENOD,U,3)
  1.  S EXFND=1  ;Record that an exact IPL match was found
  1.  ;
  1.  ;Locate PIP entry
  1.  S PFND=0,(PPIEN,PIPIEN)="" F  S PPIEN=$O(^BJPNPL("E",PIEN,PPIEN)) Q:PPIEN=""  D  Q:PFND
  1.  . ;
  1.  . ;Skip deletes
  1.  . I $$GET1^DIQ(90680.01,PPIEN_",",2.01,"I")]"" Q
  1.  . ;
  1.  . ;Found a match
  1.  . S PFND=1,PIPIEN=PPIEN
  1.  ;
  1.  ;Get external laterality
  1.  S EXLAT="" I $TR(PLAT,"|")]"" S EXLAT=$$CVPARM^BSTSMAP1("LAT",$P(PLAT,"|"))_"|"_$$CVPARM^BSTSMAP1("LAT",$P(PLAT,"|",2))
  1.  ;
  1.  ;Get ICD and default status
  1.  S PRMLST="" I $P(PLAT,"|",2)]"" S PRMLST="LAT="_$P(PLAT,"|",2)
  1.  S DDATA=$$DESC^BSTSAPI(DESCID_"^^1^^^"_PRMLST)
  1.  ;
  1.  ;Get ICD, default status, and prompt laterality
  1.  S ICD=$P(DDATA,U,3)
  1.  S DSTS=$P(DDATA,U,7)
  1.  S PMLT=$P(DDATA,U,6)
  1.  ;
  1.  ;Save the entry
  1.  S TII=$G(TII)+1,TMP(TII)=PCNC_U_PLAT_U_PDSC_U_PDST_U_PIEN_U_$S(PIPIEN]"":PIPIEN,1:0)_U_ITYPE_U_PNXT_U_EEXT_U_EXLAT_U_ICD_U_DSTS_U_$S(PMLT:"Y",1:"")_U_PNAR_U_LATCNC
  1.  I EEXT S TMP("EXACT")=TII ;Record if this was an exact match
  1.  ;
  1.  Q 1
  1.  ;
  1. PKCHECK(DATA,VIEN,CONCID,LAT,PKLIST) ;EP - BJPN CHECK PICKLIST PROBLEM
  1.  ;
  1.  ;This RPC checks to see if a particular SNOMED CT is on a patient's
  1.  ;PIP or IPL.
  1.  ;
  1.  ;Input parameter:
  1.  ;   VIEN - Visit IEN
  1.  ; CONCID - Concept Id
  1.  ;    LAT - Laterality Attribute|Value
  1.  ; PKLIST - The IEN of the Pick List used
  1.  ;
  1.  ;Input checks
  1.  I $G(VIEN)="" S BMXSEC="Missing VIEN value" G XPKCHECK
  1.  I $G(CONCID)="" S BMXSEC="Missing Concept ID" G XPKCHECK
  1.  S PKLIST=$G(PKLIST)
  1.  S LAT=$G(LAT)
  1.  ;
  1.  NEW UID,II,PRBIEN,PIPIEN,EQCN,CENT,FOUND,ITYPE,DFN,DFSTS
  1.  ;
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BJPNPCHK",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^BJPNPCHK D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
  1.  ;
  1.  ;Get the DFN
  1.  S DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I")
  1.  ;
  1.  ;Define Header
  1.  S @DATA@(0)="I00010PRBIEN^I00010PIPIEN^T00050NEXT_PRB^T00001PATIENT_TYPE^T00030STATUS^T00001PIP_STATUS"_$C(30)
  1.  ;
  1.  ;Call BSTS to find the equivalent concepts
  1.  D EQUIV^BSTSAPI("EQCN",CONCID_U_LAT)
  1.  ;
  1.  ;Return blank if no findings
  1.  I $O(EQCN(""))="" D  G XPKCHECK
  1.  . S II=II+1,@DATA@(II)="0^0^^^^"_$C(30)
  1.  ;
  1.  ;Now loop through the returned values and look for an exact match
  1.  S FOUND="0^0^^^^",CENT="" F  S CENT=$O(EQCN(CENT)) Q:CENT=""  D  I +FOUND Q
  1.  . ;
  1.  . NEW ENOD,ECNC,ELAT
  1.  . ;
  1.  . ;Pull the returned record
  1.  . S ENOD=EQCN(CENT) Q:$TR(ENOD,U)=""
  1.  . ;
  1.  . ;Quit if not exact match
  1.  . I $P(ENOD,U,3)'=1 Q
  1.  . ;
  1.  . ;Pull concept ID and laterality
  1.  . S ECNC=$P(ENOD,U) Q:ECNC=""
  1.  . S ELAT=$P(ENOD,U,2)
  1.  . ;
  1.  . ;Have laterality - Look in "ASLT" cross reference
  1.  . I $TR(ELAT,"|")]"" D
  1.  .. ;
  1.  .. NEW PIEN
  1.  .. S PIEN="" F  S PIEN=$O(^AUPNPROB("ASLT",DFN,ECNC,ELAT,PIEN)) Q:PIEN=""  S FOUND=$$FPROB(PIEN,ENOD) I +FOUND Q
  1.  . ;
  1.  . ;No laterality - Look in "APCT" cross reference
  1.  . I $TR(ELAT,"|")="" D
  1.  .. ;
  1.  .. NEW PIEN
  1.  .. S PIEN="" F  S PIEN=$O(^AUPNPROB("APCT",DFN,ECNC,PIEN)) Q:PIEN=""  S FOUND=$$FPROB(PIEN,ENOD) I +FOUND Q
  1.  ;
  1.  ;Get the next problem number
  1.  I 'FOUND D
  1.  . NEW RET
  1.  . D NEXTID^BGOPROB(.RET,DFN)
  1.  . S $P(FOUND,U,3)=RET
  1.  ;
  1.  ;Get the visit type
  1.  S ITYPE=$$GET1^DIQ(9000010,VIEN_",",.07,"I")
  1.  S ITYPE=$S(ITYPE="H":"H",1:"A")
  1.  S $P(FOUND,U,4)=ITYPE
  1.  ;
  1.  ;Update Frequency Counter if straight add
  1.  I $P(FOUND,U)=0,+$G(PKLIST)>0,+$G(CONCID)>0 D
  1.  . NEW PKEN,COUNT,IENS,DA,FUPD,ERROR
  1.  . S PKEN=$O(^BGOSNOPR(PKLIST,1,"B",CONCID,"")) Q:PKEN=""
  1.  . S DA(1)=PKLIST,DA=PKEN,IENS=$$IENS^DILF(.DA)
  1.  . S COUNT=+$$GET1^DIQ(90362.342,IENS,.03,"I")+1
  1.  . S FUPD(90362.342,IENS,.03)=COUNT
  1.  . D FILE^DIE("","FUPD","ERROR")
  1.  ;
  1.  ;Get the default status
  1.  I $P(FOUND,U)=0 S DFSTS=$P($$CONC^BSTSAPI(CONCID),U,9),$P(FOUND,U,5)=DFSTS
  1.  ;
  1.  ;Define output
  1.  S II=II+1,@DATA@(II)=FOUND_$C(30)
  1. XPKCHECK  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1.  ;Try to find the problem on the IPL/PIP
  1. FPROB(PIEN,ENOD) ;Set up return entry for problem
  1.  ;
  1.  I +$G(PIEN)=0 Q "0^0^"
  1.  ;
  1.  ;Skip deleted problems
  1.  I $$GET1^DIQ(9000011,PIEN_",",2.02,"I")]"" Q "0^0^"
  1.  ;
  1.  NEW PLAT,PFND,PPIEN,PIPIEN,NXTPRB,PSTS
  1.  ;
  1.  ;If matching concept id and no laterality passed in, filter out those with laterality
  1.  S PLAT=$$GET1^DIQ(9000011,PIEN_",",.22,"I") ;Laterality
  1.  I $P(ENOD,U,2)="",PLAT]"" Q "0^0^^^^"
  1.  ;
  1.  ;Locate PIP entry
  1.  S (PIPIEN,PFND)=0,(PSTS,PPIEN)="" F  S PPIEN=$O(^BJPNPL("E",PIEN,PPIEN)) Q:PPIEN=""  D  Q:PFND
  1.  . ;
  1.  . ;Skip deletes
  1.  . I $$GET1^DIQ(90680.01,PPIEN_",",2.01,"I")]"" Q
  1.  . ;
  1.  . ;Found a match
  1.  . S PFND=1,PIPIEN=PPIEN
  1.  . ;
  1.  . ;Get the PIP Status
  1.  . S PSTS=$$GET1^DIQ(90680.01,PIPIEN_",",.08,"E") S:PSTS="Inactive" PSTS=""
  1.  ;
  1.  ;Get next problem
  1.  S NXTPRB=$$GET1^DIQ(9000011,PIEN_",",.07,"I")
  1.  ;
  1.  Q PIEN_U_PIPIEN_U_NXTPRB_U_U_U_PSTS
  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