BJPNPCHK ;GDIT/HS/BEE-Prenatal Care Module Duplicate Problem Checking ; 08 May 2012 12:00 PM
;;2.0;PRENATAL CARE MODULE;**7**;Feb 24, 2015;Build 53
;
Q
;
PCHECK(DATA,DFN,CONCID,VIEN,DESCID,LAT,PRBIEN,PIPIEN) ;EP - BJPN CHECK FOR PROBLEM
;
;This RPC checks to see if a particular SNOMED CT/Laterality or its equivalent concept is on a patient's
;PIP or IPL.
;
;Input parameter:
; DFN - Patient DFN
; CONCID - The Concept ID to lookup
; VIEN - Visit IEN
; DESCID - Description Id (Required if CONCID is null)
; LAT - Laterality (Optional) - The internal attribute|laterality value
; PRBIEN - The problem IEN of the problem being modified (if applicable)
; PIPIEN - The PIP IEN of the problem being modified (if applicable)
;
;Input checks
S LAT=$G(LAT)
S PRBIEN=+$G(PRBIEN)
S PIPIEN=+$G(PIPIEN)
I $G(DFN)="" S BMXSEC="Missing patient DFN value" G XPCHECK
I $G(CONCID)="" S BMXSEC="Missing Concept ID" G XPCHECK
I $G(DESCID)="" S BMXSEC="Missing Description ID" G XPCHECK
I $G(VIEN)="" S BMXSEC="Missing VIEN value" G XPCHECK
I $G(DUZ(2))="" S BMXSEC="DUZ(2) is not properly defined" G XPCHECK
;
NEW UID,II,NXTPRB,EQCN,CENT,ITYPE,TMP,TII,EXFND,PCNC,PDSC,PNXT,EXMNOPRB
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPCHK",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
;Get current problem information
S (PCNC,PDSC,PNXT)="" I +PRBIEN D
. S PCNC=$$GET1^DIQ(9000011,PRBIEN_",",80001,"I") ;Current concept id
. S PDSC=$$GET1^DIQ(9000011,PRBIEN_",",80002,"I") ;Current description id
. S PNXT=$$GET1^DIQ(9000011,PRBIEN_",",.07,"I") ;Next Problem Value
;
S (II,TII)=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPCHK D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define Header
S @DATA@(0)="T00030CONC_ID^T00025INT_LATERALITY^T00030DESC_ID^T00500DESC_TERM^I00010PRBIEN^I00010PIPIEN^T00001PATIENT_TYPE"
S @DATA@(0)=@DATA@(0)_"^T00050NEXT_PRB^T00001EXACT_MATCH^T00040EXT_LATERALITY^T00015ICD^T00030STATUS"
S @DATA@(0)=@DATA@(0)_"^T00001PROMPT_LATERALITY^T00500PROVIDER_NARRATIVE^T00001LATERALIZED_CONCEPT"_$C(30)
;
;Call BSTS to find the equivalent concepts
D EQUIV^BSTSAPI("EQCN",CONCID_U_LAT)
I $O(EQCN(""))="" G XPCHECK
;
;Get the next problem number
D
. NEW RET
. D NEXTID^BGOPROB(.RET,DFN)
. S NXTPRB=RET
;
;Get the visit type
S ITYPE=$$GET1^DIQ(9000010,VIEN_",",.07,"I")
S ITYPE=$S(ITYPE="H":"H",1:"A")
;
;Now loop through the returned values and look for them
S (EXMNOPRB,EXFND)=0,CENT="" F S CENT=$O(EQCN(CENT)) Q:CENT="" D
. ;
. NEW ENOD,ECNC,FND,ELAT,F,EEXT,LATCNC
. ;
. ;Pull the returned record
. S ENOD=EQCN(CENT) Q:$TR(ENOD,U)=""
. S ECNC=$P(ENOD,U)
. S ELAT=$P(ENOD,U,2)
. S EEXT=$P(ENOD,U,3)
. S FND=0
. ;
. ;For first concept return laterality
. S LATCNC="" I CENT=1,$P(ENOD,U,4)=1 S LATCNC="Y"
. ;
. ;Have laterality - Look in "ASLT" cross reference
. I $TR(ELAT,"|")]"" D
.. ;
.. NEW PIEN
.. 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
. ;
. ;No laterality - Look in "APCT" cross reference
. I $TR(ELAT,"|")="" D
.. ;
.. NEW PIEN
.. 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
. ;
. ;If not found, return entry
. I FND=0,CONCID=ECNC,LAT=ELAT D
.. ;
.. NEW PDST,EXLAT,ICD,DSTS,DDATA,PRMLST,PMLT
.. S PRMLST="" I $P(ELAT,"|",2)]"" S PRMLST="LAT="_$P(ELAT,"|",2)
.. S DDATA=$$DESC^BSTSAPI(DESCID_"^^1^^^"_PRMLST)
.. S PDST=$P(DDATA,U,2)
.. ;
.. ;Get external laterality
.. S EXLAT="" I $TR(ELAT,"|")]"" S EXLAT=$$CVPARM^BSTSMAP1("LAT",$P(ELAT,"|"))_"|"_$$CVPARM^BSTSMAP1("LAT",$P(ELAT,"|",2))
.. ;
.. ;Get ICD, default status and prompt laterality
.. S ICD=$P(DDATA,U,3)
.. S DSTS=$P(DDATA,U,7)
.. S PMLT=$P(DDATA,U,6)
.. ;
.. ;No match found - log that entry can be used
.. 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
.. I EEXT S EXMNOPRB=1 ;Track if an exact match
;
;Loop through results - eliminate others if exact match found
S TII="" F S TII=$O(TMP(TII)) Q:'TII D
. ;
. NEW TNODE
. S TNODE=TMP(TII)
. ;
. ;Special logic for exact match found on IPL - Only include it
. I $D(TMP("EXACT")) D Q
.. ;
.. NEW EXNODE
.. ;
.. ;Get the exact match
.. S EXNODE=TMP(TMP("EXACT"))
.. ;
.. ;If not an exact match do not include
.. I '$P(TNODE,U,9) Q
.. ;
.. ;Passed in problem is the same as the exact match problem
.. ;
.. I +PRBIEN,PRBIEN=$P(EXNODE,U,5) D Q
... ;
... ;The user switched to the equivalent concept - update original
... ;passed in problem info with new SNOMED/laterality information
... I $P(TNODE,U,9)=1,$P(TNODE,U,5)=0 D Q
.... NEW I
.... S EXNODE=TMP(TMP("EXACT"))
.... F I=5:1:9 S $P(TNODE,U,I)=$P(EXNODE,U,I)
.... S II=II+1,@DATA@(II)=TNODE_$C(30)
... ;
... ;The user picked the same concept - return original
... I $P(TNODE,U,9)=1,TMP("EXACT")=TII D Q
.... Q:CONCID'=$P(TNODE,U) ;Concept not the same
.... Q:LAT'=$P(TNODE,U,2) ;Laterality not the same
.... S TNODE=TMP(TMP("EXACT"))
.... S II=II+1,@DATA@(II)=TNODE_$C(30)
.. ;
.. ;No passed in problem or not a match with exact
.. ;
.. ;If exact match, allow - GUI will utilize IPL problem returned
.. I TMP("EXACT")=TII D Q
... S TNODE=TMP(TMP("EXACT"))_$C(30)
... S II=II+1,@DATA@(II)=TNODE
. ;
. ;Problem edit - changed SNOMED and it isn't a match on IPL
. ;update entry with passed in problem information
. I +PRBIEN,$P(TNODE,U,5)="" D Q
.. S $P(TNODE,U,5)=PRBIEN
.. S $P(TNODE,U,6)=PIPIEN
.. S $P(TNODE,U,7)=ITYPE
.. S $P(TNODE,U,8)=PNXT
.. S II=II+1,@DATA@(II)=TNODE_$C(30)
. ;
. ;Not an exact match on IPL, exact found by BSTS and edit fill entries
. I +PIPIEN,EXMNOPRB D Q ;Edit and an exact match was saved
.. I $P(TNODE,U,9) D ;This is the exact match
... S $P(TNODE,U,5)=PRBIEN
... S $P(TNODE,U,6)=PIPIEN
... S $P(TNODE,U,7)=ITYPE
... S $P(TNODE,U,8)=PNXT
... S II=II+1,@DATA@(II)=TNODE_$C(30)
. ;
. ;No exact matches - save related ones
. S II=II+1,@DATA@(II)=TNODE_$C(30)
;
XPCHECK S II=$G(II)+1,@DATA@(II)=$C(31)
;
Q
;
GPROB(TMP,PIEN,ENOD,ITYPE,EXFND,TII,LATCNC) ;Set up return entry for problem
;
I +$G(PIEN)=0 Q 0
;
;Skip deleted problems
I $$GET1^DIQ(9000011,PIEN_",",2.02,"I")]"" Q 0
;
NEW PCNC,PDSC,PDST,PNXT,PIPIEN,PFND,PPIEN,EEXT,PLAT,EXLAT,ICD,DSTS,DDATA,PRMLST,PMLT,PNAR
;
;If matching concept id and no laterality passed in, filter out those with laterality
S PLAT=$$GET1^DIQ(9000011,PIEN_",",.22,"I") ;Laterality
I $P(ENOD,U,2)="",PLAT]"" Q 0
;
S PCNC=$$GET1^DIQ(9000011,PIEN_",",80001,"I") ;Concept ID
S PDSC=$$GET1^DIQ(9000011,PIEN_",",80002,"I") ;Description ID
S PNAR=$$GET1^DIQ(9000011,PIEN_",",.05,"E") ;Provider narrative
S PDST=$P($$DESC^BSTSAPI(PDSC_"^^1"),U,2) ;Description Term
S PNXT=$$GET1^DIQ(9000011,PIEN_",",.07,"I") ;Next Problem Value
S EEXT=$P(ENOD,U,3)
S EXFND=1 ;Record that an exact IPL match was found
;
;Locate PIP entry
S PFND=0,(PPIEN,PIPIEN)="" F S PPIEN=$O(^BJPNPL("E",PIEN,PPIEN)) Q:PPIEN="" D Q:PFND
. ;
. ;Skip deletes
. I $$GET1^DIQ(90680.01,PPIEN_",",2.01,"I")]"" Q
. ;
. ;Found a match
. S PFND=1,PIPIEN=PPIEN
;
;Get external laterality
S EXLAT="" I $TR(PLAT,"|")]"" S EXLAT=$$CVPARM^BSTSMAP1("LAT",$P(PLAT,"|"))_"|"_$$CVPARM^BSTSMAP1("LAT",$P(PLAT,"|",2))
;
;Get ICD and default status
S PRMLST="" I $P(PLAT,"|",2)]"" S PRMLST="LAT="_$P(PLAT,"|",2)
S DDATA=$$DESC^BSTSAPI(DESCID_"^^1^^^"_PRMLST)
;
;Get ICD, default status, and prompt laterality
S ICD=$P(DDATA,U,3)
S DSTS=$P(DDATA,U,7)
S PMLT=$P(DDATA,U,6)
;
;Save the entry
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
I EEXT S TMP("EXACT")=TII ;Record if this was an exact match
;
Q 1
;
PKCHECK(DATA,VIEN,CONCID,LAT,PKLIST) ;EP - BJPN CHECK PICKLIST PROBLEM
;
;This RPC checks to see if a particular SNOMED CT is on a patient's
;PIP or IPL.
;
;Input parameter:
; VIEN - Visit IEN
; CONCID - Concept Id
; LAT - Laterality Attribute|Value
; PKLIST - The IEN of the Pick List used
;
;Input checks
I $G(VIEN)="" S BMXSEC="Missing VIEN value" G XPKCHECK
I $G(CONCID)="" S BMXSEC="Missing Concept ID" G XPKCHECK
S PKLIST=$G(PKLIST)
S LAT=$G(LAT)
;
NEW UID,II,PRBIEN,PIPIEN,EQCN,CENT,FOUND,ITYPE,DFN,DFSTS
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPCHK",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPCHK D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Get the DFN
S DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I")
;
;Define Header
S @DATA@(0)="I00010PRBIEN^I00010PIPIEN^T00050NEXT_PRB^T00001PATIENT_TYPE^T00030STATUS^T00001PIP_STATUS"_$C(30)
;
;Call BSTS to find the equivalent concepts
D EQUIV^BSTSAPI("EQCN",CONCID_U_LAT)
;
;Return blank if no findings
I $O(EQCN(""))="" D G XPKCHECK
. S II=II+1,@DATA@(II)="0^0^^^^"_$C(30)
;
;Now loop through the returned values and look for an exact match
S FOUND="0^0^^^^",CENT="" F S CENT=$O(EQCN(CENT)) Q:CENT="" D I +FOUND Q
. ;
. NEW ENOD,ECNC,ELAT
. ;
. ;Pull the returned record
. S ENOD=EQCN(CENT) Q:$TR(ENOD,U)=""
. ;
. ;Quit if not exact match
. I $P(ENOD,U,3)'=1 Q
. ;
. ;Pull concept ID and laterality
. S ECNC=$P(ENOD,U) Q:ECNC=""
. S ELAT=$P(ENOD,U,2)
. ;
. ;Have laterality - Look in "ASLT" cross reference
. I $TR(ELAT,"|")]"" D
.. ;
.. NEW PIEN
.. S PIEN="" F S PIEN=$O(^AUPNPROB("ASLT",DFN,ECNC,ELAT,PIEN)) Q:PIEN="" S FOUND=$$FPROB(PIEN,ENOD) I +FOUND Q
. ;
. ;No laterality - Look in "APCT" cross reference
. I $TR(ELAT,"|")="" D
.. ;
.. NEW PIEN
.. S PIEN="" F S PIEN=$O(^AUPNPROB("APCT",DFN,ECNC,PIEN)) Q:PIEN="" S FOUND=$$FPROB(PIEN,ENOD) I +FOUND Q
;
;Get the next problem number
I 'FOUND D
. NEW RET
. D NEXTID^BGOPROB(.RET,DFN)
. S $P(FOUND,U,3)=RET
;
;Get the visit type
S ITYPE=$$GET1^DIQ(9000010,VIEN_",",.07,"I")
S ITYPE=$S(ITYPE="H":"H",1:"A")
S $P(FOUND,U,4)=ITYPE
;
;Update Frequency Counter if straight add
I $P(FOUND,U)=0,+$G(PKLIST)>0,+$G(CONCID)>0 D
. NEW PKEN,COUNT,IENS,DA,FUPD,ERROR
. S PKEN=$O(^BGOSNOPR(PKLIST,1,"B",CONCID,"")) Q:PKEN=""
. S DA(1)=PKLIST,DA=PKEN,IENS=$$IENS^DILF(.DA)
. S COUNT=+$$GET1^DIQ(90362.342,IENS,.03,"I")+1
. S FUPD(90362.342,IENS,.03)=COUNT
. D FILE^DIE("","FUPD","ERROR")
;
;Get the default status
I $P(FOUND,U)=0 S DFSTS=$P($$CONC^BSTSAPI(CONCID),U,9),$P(FOUND,U,5)=DFSTS
;
;Define output
S II=II+1,@DATA@(II)=FOUND_$C(30)
XPKCHECK S II=II+1,@DATA@(II)=$C(31)
Q
;
;Try to find the problem on the IPL/PIP
FPROB(PIEN,ENOD) ;Set up return entry for problem
;
I +$G(PIEN)=0 Q "0^0^"
;
;Skip deleted problems
I $$GET1^DIQ(9000011,PIEN_",",2.02,"I")]"" Q "0^0^"
;
NEW PLAT,PFND,PPIEN,PIPIEN,NXTPRB,PSTS
;
;If matching concept id and no laterality passed in, filter out those with laterality
S PLAT=$$GET1^DIQ(9000011,PIEN_",",.22,"I") ;Laterality
I $P(ENOD,U,2)="",PLAT]"" Q "0^0^^^^"
;
;Locate PIP entry
S (PIPIEN,PFND)=0,(PSTS,PPIEN)="" F S PPIEN=$O(^BJPNPL("E",PIEN,PPIEN)) Q:PPIEN="" D Q:PFND
. ;
. ;Skip deletes
. I $$GET1^DIQ(90680.01,PPIEN_",",2.01,"I")]"" Q
. ;
. ;Found a match
. S PFND=1,PIPIEN=PPIEN
. ;
. ;Get the PIP Status
. S PSTS=$$GET1^DIQ(90680.01,PIPIEN_",",.08,"E") S:PSTS="Inactive" PSTS=""
;
;Get next problem
S NXTPRB=$$GET1^DIQ(9000011,PIEN_",",.07,"I")
;
Q PIEN_U_PIPIEN_U_NXTPRB_U_U_U_PSTS
;
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
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
+2 ;
+3 QUIT
+4 ;
PCHECK(DATA,DFN,CONCID,VIEN,DESCID,LAT,PRBIEN,PIPIEN) ;EP - BJPN CHECK FOR PROBLEM
+1 ;
+2 ;This RPC checks to see if a particular SNOMED CT/Laterality or its equivalent concept is on a patient's
+3 ;PIP or IPL.
+4 ;
+5 ;Input parameter:
+6 ; DFN - Patient DFN
+7 ; CONCID - The Concept ID to lookup
+8 ; VIEN - Visit IEN
+9 ; DESCID - Description Id (Required if CONCID is null)
+10 ; LAT - Laterality (Optional) - The internal attribute|laterality value
+11 ; PRBIEN - The problem IEN of the problem being modified (if applicable)
+12 ; PIPIEN - The PIP IEN of the problem being modified (if applicable)
+13 ;
+14 ;Input checks
+15 SET LAT=$GET(LAT)
+16 SET PRBIEN=+$GET(PRBIEN)
+17 SET PIPIEN=+$GET(PIPIEN)
+18 IF $GET(DFN)=""
SET BMXSEC="Missing patient DFN value"
GOTO XPCHECK
+19 IF $GET(CONCID)=""
SET BMXSEC="Missing Concept ID"
GOTO XPCHECK
+20 IF $GET(DESCID)=""
SET BMXSEC="Missing Description ID"
GOTO XPCHECK
+21 IF $GET(VIEN)=""
SET BMXSEC="Missing VIEN value"
GOTO XPCHECK
+22 IF $GET(DUZ(2))=""
SET BMXSEC="DUZ(2) is not properly defined"
GOTO XPCHECK
+23 ;
+24 NEW UID,II,NXTPRB,EQCN,CENT,ITYPE,TMP,TII,EXFND,PCNC,PDSC,PNXT,EXMNOPRB
+25 ;
+26 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+27 SET DATA=$NAME(^TMP("BJPNPCHK",UID))
+28 KILL @DATA
+29 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+30 ;
+31 ;Get current problem information
+32 SET (PCNC,PDSC,PNXT)=""
IF +PRBIEN
Begin DoDot:1
+33 ;Current concept id
SET PCNC=$$GET1^DIQ(9000011,PRBIEN_",",80001,"I")
+34 ;Current description id
SET PDSC=$$GET1^DIQ(9000011,PRBIEN_",",80002,"I")
+35 ;Next Problem Value
SET PNXT=$$GET1^DIQ(9000011,PRBIEN_",",.07,"I")
End DoDot:1
+36 ;
+37 SET (II,TII)=0
+38 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPCHK D UNWIND^%ZTER"
+39 ;
+40 ;Define Header
+41 SET @DATA@(0)="T00030CONC_ID^T00025INT_LATERALITY^T00030DESC_ID^T00500DESC_TERM^I00010PRBIEN^I00010PIPIEN^T00001PATIENT_TYPE"
+42 SET @DATA@(0)=@DATA@(0)_"^T00050NEXT_PRB^T00001EXACT_MATCH^T00040EXT_LATERALITY^T00015ICD^T00030STATUS"
+43 SET @DATA@(0)=@DATA@(0)_"^T00001PROMPT_LATERALITY^T00500PROVIDER_NARRATIVE^T00001LATERALIZED_CONCEPT"_$CHAR(30)
+44 ;
+45 ;Call BSTS to find the equivalent concepts
+46 DO EQUIV^BSTSAPI("EQCN",CONCID_U_LAT)
+47 IF $ORDER(EQCN(""))=""
GOTO XPCHECK
+48 ;
+49 ;Get the next problem number
+50 Begin DoDot:1
+51 NEW RET
+52 DO NEXTID^BGOPROB(.RET,DFN)
+53 SET NXTPRB=RET
End DoDot:1
+54 ;
+55 ;Get the visit type
+56 SET ITYPE=$$GET1^DIQ(9000010,VIEN_",",.07,"I")
+57 SET ITYPE=$SELECT(ITYPE="H":"H",1:"A")
+58 ;
+59 ;Now loop through the returned values and look for them
+60 SET (EXMNOPRB,EXFND)=0
SET CENT=""
FOR
SET CENT=$ORDER(EQCN(CENT))
IF CENT=""
QUIT
Begin DoDot:1
+61 ;
+62 NEW ENOD,ECNC,FND,ELAT,F,EEXT,LATCNC
+63 ;
+64 ;Pull the returned record
+65 SET ENOD=EQCN(CENT)
IF $TRANSLATE(ENOD,U)=""
QUIT
+66 SET ECNC=$PIECE(ENOD,U)
+67 SET ELAT=$PIECE(ENOD,U,2)
+68 SET EEXT=$PIECE(ENOD,U,3)
+69 SET FND=0
+70 ;
+71 ;For first concept return laterality
+72 SET LATCNC=""
IF CENT=1
IF $PIECE(ENOD,U,4)=1
SET LATCNC="Y"
+73 ;
+74 ;Have laterality - Look in "ASLT" cross reference
+75 IF $TRANSLATE(ELAT,"|")]""
Begin DoDot:2
+76 ;
+77 NEW PIEN
+78 SET PIEN=""
FOR
SET PIEN=$ORDER(^AUPNPROB("ASLT",DFN,ECNC,ELAT,PIEN))
IF PIEN=""
QUIT
SET F=$$GPROB(.TMP,PIEN,ENOD,ITYPE,.EXFND,.TII,LATCNC)
IF F
SET FND=1
End DoDot:2
+79 ;
+80 ;No laterality - Look in "APCT" cross reference
+81 IF $TRANSLATE(ELAT,"|")=""
Begin DoDot:2
+82 ;
+83 NEW PIEN
+84 SET PIEN=""
FOR
SET PIEN=$ORDER(^AUPNPROB("APCT",DFN,ECNC,PIEN))
IF PIEN=""
QUIT
SET F=$$GPROB(.TMP,PIEN,ENOD,ITYPE,.EXFND,.TII,LATCNC)
IF F
SET FND=1
End DoDot:2
+85 ;
+86 ;If not found, return entry
+87 IF FND=0
IF CONCID=ECNC
IF LAT=ELAT
Begin DoDot:2
+88 ;
+89 NEW PDST,EXLAT,ICD,DSTS,DDATA,PRMLST,PMLT
+90 SET PRMLST=""
IF $PIECE(ELAT,"|",2)]""
SET PRMLST="LAT="_$PIECE(ELAT,"|",2)
+91 SET DDATA=$$DESC^BSTSAPI(DESCID_"^^1^^^"_PRMLST)
+92 SET PDST=$PIECE(DDATA,U,2)
+93 ;
+94 ;Get external laterality
+95 SET EXLAT=""
IF $TRANSLATE(ELAT,"|")]""
SET EXLAT=$$CVPARM^BSTSMAP1("LAT",$PIECE(ELAT,"|"))_"|"_$$CVPARM^BSTSMAP1("LAT",$PIECE(ELAT,"|",2))
+96 ;
+97 ;Get ICD, default status and prompt laterality
+98 SET ICD=$PIECE(DDATA,U,3)
+99 SET DSTS=$PIECE(DDATA,U,7)
+100 SET PMLT=$PIECE(DDATA,U,6)
+101 ;
+102 ;No match found - log that entry can be used
+103 SET TII=$GET(TII)+1
SET 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_$SELECT(PMLT:"Y",1:"")_U_U_LATCNC
+104 ;Track if an exact match
IF EEXT
SET EXMNOPRB=1
End DoDot:2
End DoDot:1
+105 ;
+106 ;Loop through results - eliminate others if exact match found
+107 SET TII=""
FOR
SET TII=$ORDER(TMP(TII))
IF 'TII
QUIT
Begin DoDot:1
+108 ;
+109 NEW TNODE
+110 SET TNODE=TMP(TII)
+111 ;
+112 ;Special logic for exact match found on IPL - Only include it
+113 IF $DATA(TMP("EXACT"))
Begin DoDot:2
+114 ;
+115 NEW EXNODE
+116 ;
+117 ;Get the exact match
+118 SET EXNODE=TMP(TMP("EXACT"))
+119 ;
+120 ;If not an exact match do not include
+121 IF '$PIECE(TNODE,U,9)
QUIT
+122 ;
+123 ;Passed in problem is the same as the exact match problem
+124 ;
+125 IF +PRBIEN
IF PRBIEN=$PIECE(EXNODE,U,5)
Begin DoDot:3
+126 ;
+127 ;The user switched to the equivalent concept - update original
+128 ;passed in problem info with new SNOMED/laterality information
+129 IF $PIECE(TNODE,U,9)=1
IF $PIECE(TNODE,U,5)=0
Begin DoDot:4
+130 NEW I
+131 SET EXNODE=TMP(TMP("EXACT"))
+132 FOR I=5:1:9
SET $PIECE(TNODE,U,I)=$PIECE(EXNODE,U,I)
+133 SET II=II+1
SET @DATA@(II)=TNODE_$CHAR(30)
End DoDot:4
QUIT
+134 ;
+135 ;The user picked the same concept - return original
+136 IF $PIECE(TNODE,U,9)=1
IF TMP("EXACT")=TII
Begin DoDot:4
+137 ;Concept not the same
IF CONCID'=$PIECE(TNODE,U)
QUIT
+138 ;Laterality not the same
IF LAT'=$PIECE(TNODE,U,2)
QUIT
+139 SET TNODE=TMP(TMP("EXACT"))
+140 SET II=II+1
SET @DATA@(II)=TNODE_$CHAR(30)
End DoDot:4
QUIT
End DoDot:3
QUIT
+141 ;
+142 ;No passed in problem or not a match with exact
+143 ;
+144 ;If exact match, allow - GUI will utilize IPL problem returned
+145 IF TMP("EXACT")=TII
Begin DoDot:3
+146 SET TNODE=TMP(TMP("EXACT"))_$CHAR(30)
+147 SET II=II+1
SET @DATA@(II)=TNODE
End DoDot:3
QUIT
End DoDot:2
QUIT
+148 ;
+149 ;Problem edit - changed SNOMED and it isn't a match on IPL
+150 ;update entry with passed in problem information
+151 IF +PRBIEN
IF $PIECE(TNODE,U,5)=""
Begin DoDot:2
+152 SET $PIECE(TNODE,U,5)=PRBIEN
+153 SET $PIECE(TNODE,U,6)=PIPIEN
+154 SET $PIECE(TNODE,U,7)=ITYPE
+155 SET $PIECE(TNODE,U,8)=PNXT
+156 SET II=II+1
SET @DATA@(II)=TNODE_$CHAR(30)
End DoDot:2
QUIT
+157 ;
+158 ;Not an exact match on IPL, exact found by BSTS and edit fill entries
+159 ;Edit and an exact match was saved
IF +PIPIEN
IF EXMNOPRB
Begin DoDot:2
+160 ;This is the exact match
IF $PIECE(TNODE,U,9)
Begin DoDot:3
+161 SET $PIECE(TNODE,U,5)=PRBIEN
+162 SET $PIECE(TNODE,U,6)=PIPIEN
+163 SET $PIECE(TNODE,U,7)=ITYPE
+164 SET $PIECE(TNODE,U,8)=PNXT
+165 SET II=II+1
SET @DATA@(II)=TNODE_$CHAR(30)
End DoDot:3
End DoDot:2
QUIT
+166 ;
+167 ;No exact matches - save related ones
+168 SET II=II+1
SET @DATA@(II)=TNODE_$CHAR(30)
End DoDot:1
+169 ;
XPCHECK SET II=$GET(II)+1
SET @DATA@(II)=$CHAR(31)
+1 ;
+2 QUIT
+3 ;
GPROB(TMP,PIEN,ENOD,ITYPE,EXFND,TII,LATCNC) ;Set up return entry for problem
+1 ;
+2 IF +$GET(PIEN)=0
QUIT 0
+3 ;
+4 ;Skip deleted problems
+5 IF $$GET1^DIQ(9000011,PIEN_",",2.02,"I")]""
QUIT 0
+6 ;
+7 NEW PCNC,PDSC,PDST,PNXT,PIPIEN,PFND,PPIEN,EEXT,PLAT,EXLAT,ICD,DSTS,DDATA,PRMLST,PMLT,PNAR
+8 ;
+9 ;If matching concept id and no laterality passed in, filter out those with laterality
+10 ;Laterality
SET PLAT=$$GET1^DIQ(9000011,PIEN_",",.22,"I")
+11 IF $PIECE(ENOD,U,2)=""
IF PLAT]""
QUIT 0
+12 ;
+13 ;Concept ID
SET PCNC=$$GET1^DIQ(9000011,PIEN_",",80001,"I")
+14 ;Description ID
SET PDSC=$$GET1^DIQ(9000011,PIEN_",",80002,"I")
+15 ;Provider narrative
SET PNAR=$$GET1^DIQ(9000011,PIEN_",",.05,"E")
+16 ;Description Term
SET PDST=$PIECE($$DESC^BSTSAPI(PDSC_"^^1"),U,2)
+17 ;Next Problem Value
SET PNXT=$$GET1^DIQ(9000011,PIEN_",",.07,"I")
+18 SET EEXT=$PIECE(ENOD,U,3)
+19 ;Record that an exact IPL match was found
SET EXFND=1
+20 ;
+21 ;Locate PIP entry
+22 SET PFND=0
SET (PPIEN,PIPIEN)=""
FOR
SET PPIEN=$ORDER(^BJPNPL("E",PIEN,PPIEN))
IF PPIEN=""
QUIT
Begin DoDot:1
+23 ;
+24 ;Skip deletes
+25 IF $$GET1^DIQ(90680.01,PPIEN_",",2.01,"I")]""
QUIT
+26 ;
+27 ;Found a match
+28 SET PFND=1
SET PIPIEN=PPIEN
End DoDot:1
IF PFND
QUIT
+29 ;
+30 ;Get external laterality
+31 SET EXLAT=""
IF $TRANSLATE(PLAT,"|")]""
SET EXLAT=$$CVPARM^BSTSMAP1("LAT",$PIECE(PLAT,"|"))_"|"_$$CVPARM^BSTSMAP1("LAT",$PIECE(PLAT,"|",2))
+32 ;
+33 ;Get ICD and default status
+34 SET PRMLST=""
IF $PIECE(PLAT,"|",2)]""
SET PRMLST="LAT="_$PIECE(PLAT,"|",2)
+35 SET DDATA=$$DESC^BSTSAPI(DESCID_"^^1^^^"_PRMLST)
+36 ;
+37 ;Get ICD, default status, and prompt laterality
+38 SET ICD=$PIECE(DDATA,U,3)
+39 SET DSTS=$PIECE(DDATA,U,7)
+40 SET PMLT=$PIECE(DDATA,U,6)
+41 ;
+42 ;Save the entry
+43 SET TII=$GET(TII)+1
SET TMP(TII)=PCNC_U_PLAT_U_PDSC_U_PDST_U_PIEN_U_$SELECT(PIPIEN]"":PIPIEN,1:0)_U_ITYPE_U_PNXT_U_EEXT_U_EXLAT_U_ICD_U_DSTS_U_$SELECT(PMLT:"Y",1:"")_U_PNAR_U_LATCNC
+44 ;Record if this was an exact match
IF EEXT
SET TMP("EXACT")=TII
+45 ;
+46 QUIT 1
+47 ;
PKCHECK(DATA,VIEN,CONCID,LAT,PKLIST) ;EP - BJPN CHECK PICKLIST PROBLEM
+1 ;
+2 ;This RPC checks to see if a particular SNOMED CT is on a patient's
+3 ;PIP or IPL.
+4 ;
+5 ;Input parameter:
+6 ; VIEN - Visit IEN
+7 ; CONCID - Concept Id
+8 ; LAT - Laterality Attribute|Value
+9 ; PKLIST - The IEN of the Pick List used
+10 ;
+11 ;Input checks
+12 IF $GET(VIEN)=""
SET BMXSEC="Missing VIEN value"
GOTO XPKCHECK
+13 IF $GET(CONCID)=""
SET BMXSEC="Missing Concept ID"
GOTO XPKCHECK
+14 SET PKLIST=$GET(PKLIST)
+15 SET LAT=$GET(LAT)
+16 ;
+17 NEW UID,II,PRBIEN,PIPIEN,EQCN,CENT,FOUND,ITYPE,DFN,DFSTS
+18 ;
+19 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+20 SET DATA=$NAME(^TMP("BJPNPCHK",UID))
+21 KILL @DATA
+22 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+23 ;
+24 SET II=0
+25 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPCHK D UNWIND^%ZTER"
+26 ;
+27 ;Get the DFN
+28 SET DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I")
+29 ;
+30 ;Define Header
+31 SET @DATA@(0)="I00010PRBIEN^I00010PIPIEN^T00050NEXT_PRB^T00001PATIENT_TYPE^T00030STATUS^T00001PIP_STATUS"_$CHAR(30)
+32 ;
+33 ;Call BSTS to find the equivalent concepts
+34 DO EQUIV^BSTSAPI("EQCN",CONCID_U_LAT)
+35 ;
+36 ;Return blank if no findings
+37 IF $ORDER(EQCN(""))=""
Begin DoDot:1
+38 SET II=II+1
SET @DATA@(II)="0^0^^^^"_$CHAR(30)
End DoDot:1
GOTO XPKCHECK
+39 ;
+40 ;Now loop through the returned values and look for an exact match
+41 SET FOUND="0^0^^^^"
SET CENT=""
FOR
SET CENT=$ORDER(EQCN(CENT))
IF CENT=""
QUIT
Begin DoDot:1
+42 ;
+43 NEW ENOD,ECNC,ELAT
+44 ;
+45 ;Pull the returned record
+46 SET ENOD=EQCN(CENT)
IF $TRANSLATE(ENOD,U)=""
QUIT
+47 ;
+48 ;Quit if not exact match
+49 IF $PIECE(ENOD,U,3)'=1
QUIT
+50 ;
+51 ;Pull concept ID and laterality
+52 SET ECNC=$PIECE(ENOD,U)
IF ECNC=""
QUIT
+53 SET ELAT=$PIECE(ENOD,U,2)
+54 ;
+55 ;Have laterality - Look in "ASLT" cross reference
+56 IF $TRANSLATE(ELAT,"|")]""
Begin DoDot:2
+57 ;
+58 NEW PIEN
+59 SET PIEN=""
FOR
SET PIEN=$ORDER(^AUPNPROB("ASLT",DFN,ECNC,ELAT,PIEN))
IF PIEN=""
QUIT
SET FOUND=$$FPROB(PIEN,ENOD)
IF +FOUND
QUIT
End DoDot:2
+60 ;
+61 ;No laterality - Look in "APCT" cross reference
+62 IF $TRANSLATE(ELAT,"|")=""
Begin DoDot:2
+63 ;
+64 NEW PIEN
+65 SET PIEN=""
FOR
SET PIEN=$ORDER(^AUPNPROB("APCT",DFN,ECNC,PIEN))
IF PIEN=""
QUIT
SET FOUND=$$FPROB(PIEN,ENOD)
IF +FOUND
QUIT
End DoDot:2
End DoDot:1
IF +FOUND
QUIT
+66 ;
+67 ;Get the next problem number
+68 IF 'FOUND
Begin DoDot:1
+69 NEW RET
+70 DO NEXTID^BGOPROB(.RET,DFN)
+71 SET $PIECE(FOUND,U,3)=RET
End DoDot:1
+72 ;
+73 ;Get the visit type
+74 SET ITYPE=$$GET1^DIQ(9000010,VIEN_",",.07,"I")
+75 SET ITYPE=$SELECT(ITYPE="H":"H",1:"A")
+76 SET $PIECE(FOUND,U,4)=ITYPE
+77 ;
+78 ;Update Frequency Counter if straight add
+79 IF $PIECE(FOUND,U)=0
IF +$GET(PKLIST)>0
IF +$GET(CONCID)>0
Begin DoDot:1
+80 NEW PKEN,COUNT,IENS,DA,FUPD,ERROR
+81 SET PKEN=$ORDER(^BGOSNOPR(PKLIST,1,"B",CONCID,""))
IF PKEN=""
QUIT
+82 SET DA(1)=PKLIST
SET DA=PKEN
SET IENS=$$IENS^DILF(.DA)
+83 SET COUNT=+$$GET1^DIQ(90362.342,IENS,.03,"I")+1
+84 SET FUPD(90362.342,IENS,.03)=COUNT
+85 DO FILE^DIE("","FUPD","ERROR")
End DoDot:1
+86 ;
+87 ;Get the default status
+88 IF $PIECE(FOUND,U)=0
SET DFSTS=$PIECE($$CONC^BSTSAPI(CONCID),U,9)
SET $PIECE(FOUND,U,5)=DFSTS
+89 ;
+90 ;Define output
+91 SET II=II+1
SET @DATA@(II)=FOUND_$CHAR(30)
XPKCHECK SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
+3 ;Try to find the problem on the IPL/PIP
FPROB(PIEN,ENOD) ;Set up return entry for problem
+1 ;
+2 IF +$GET(PIEN)=0
QUIT "0^0^"
+3 ;
+4 ;Skip deleted problems
+5 IF $$GET1^DIQ(9000011,PIEN_",",2.02,"I")]""
QUIT "0^0^"
+6 ;
+7 NEW PLAT,PFND,PPIEN,PIPIEN,NXTPRB,PSTS
+8 ;
+9 ;If matching concept id and no laterality passed in, filter out those with laterality
+10 ;Laterality
SET PLAT=$$GET1^DIQ(9000011,PIEN_",",.22,"I")
+11 IF $PIECE(ENOD,U,2)=""
IF PLAT]""
QUIT "0^0^^^^"
+12 ;
+13 ;Locate PIP entry
+14 SET (PIPIEN,PFND)=0
SET (PSTS,PPIEN)=""
FOR
SET PPIEN=$ORDER(^BJPNPL("E",PIEN,PPIEN))
IF PPIEN=""
QUIT
Begin DoDot:1
+15 ;
+16 ;Skip deletes
+17 IF $$GET1^DIQ(90680.01,PPIEN_",",2.01,"I")]""
QUIT
+18 ;
+19 ;Found a match
+20 SET PFND=1
SET PIPIEN=PPIEN
+21 ;
+22 ;Get the PIP Status
+23 SET PSTS=$$GET1^DIQ(90680.01,PIPIEN_",",.08,"E")
IF PSTS="Inactive"
SET PSTS=""
End DoDot:1
IF PFND
QUIT
+24 ;
+25 ;Get next problem
+26 SET NXTPRB=$$GET1^DIQ(9000011,PIEN_",",.07,"I")
+27 ;
+28 QUIT PIEN_U_PIPIEN_U_NXTPRB_U_U_U_PSTS
+29 ;
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
