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

BJPNPRL.m

Go to the documentation of this file. 
  1. BJPNPRL ;GDIT/HS/BEE-Prenatal Care Module Problem List ; 08 May 2012  12:00 PM
  1.  ;;2.0;PRENATAL CARE MODULE;**3,7,8**;Feb 24, 2015;Build 25
  1.  ;
  1.  Q
  1.  ;
  1. HDR(DATA,DFN) ;EP - BJPN GET PRLIST HDR
  1.  ;
  1.  ;This RPC returns header information pertaining to the prenatal problem list
  1.  ;
  1.  ;Input:  DFN - Patient IEN
  1.  ;
  1.  NEW UID,II,PSTS,RFEDD,PREDD,PRBIEN,PENT,HPIP
  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.  I $G(DFN)="" G DONE
  1.  ;
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPRL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
  1.  ;
  1.  S @DATA@(II)="T00001PREGNANCY_STATUS^D00015DEFINITIVE_EDD^D00015PRLIST_EDD^T00010PIP_ENTRIES^T00001HAS_PIP"_$C(30)
  1.  ;
  1.  ;Currenty Pregnant?
  1.  S PSTS=$$GET1^DIQ(9000017,DFN_",",1101,"I")
  1.  ;
  1.  ;Definitive EDD
  1.  S RFEDD=$$FMTE($$GET1^DIQ(9000017,DFN_",",1311,"I"))
  1.  ;
  1.  ;Problem List EDD - Pull from first non-deleted entry
  1.  S PREDD="",PENT=0,HPIP=""
  1.  S PRBIEN="" F  S PRBIEN=$O(^BJPNPL("F",DFN,PRBIEN)) Q:PRBIEN=""  D  Q:PREDD]""
  1.  . NEW BPIEN
  1.  . S BPIEN="" F  S BPIEN=$O(^BJPNPL("F",DFN,PRBIEN,BPIEN)) Q:BPIEN=""  D  Q:PREDD]""
  1.  .. NEW DEL
  1.  .. ;
  1.  .. ;Skip deletes
  1.  .. S DEL=$$GET1^DIQ(90680.01,BPIEN_",",2.01,"I") Q:DEL]""
  1.  .. ;
  1.  .. ;Has PIP Entry
  1.  .. S HPIP="Y"
  1.  .. ;
  1.  .. ;Definitive EDD
  1.  .. S PREDD=$$FMTE($$GET1^DIQ(90680.01,BPIEN_",",.09,"I"))
  1.  .. Q:PREDD=""
  1.  .. S PENT=1
  1.  ;
  1.  S II=II+1,@DATA@(II)=PSTS_U_RFEDD_U_PREDD_U_PENT_U_HPIP_$C(30)
  1.  ;
  1. DONE S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. VLOCK(DATA,VIEN) ;EP - BJPN VISIT LOCK CHK
  1.  ;
  1.  ;This RPC returns whether a particular visit has been locked for editing
  1.  ;
  1.  ;Input:  VIEN - Visit IEN
  1.  ;
  1.  NEW UID,II,LOCK,ITYPE
  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.  I $G(VIEN)="" G XVLCK
  1.  ;
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPRL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
  1.  ;
  1.  S @DATA@(II)="I00001VISIT_LOCKED^T00001INPATIENT"_$C(30)
  1.  ;
  1.  ;Check for visit lock
  1.  S LOCK=$$ISLOCKED^BEHOENCX(VIEN)
  1.  S LOCK=$S(LOCK:1,1:0)
  1.  ;
  1.  ;Get the visit type
  1.  S ITYPE=$$GET1^DIQ(9000010,VIEN_",",.07,"I")
  1.  S ITYPE=$S(ITYPE="H":"Y",1:"")
  1.  ;
  1.  S II=II+1,@DATA@(II)=LOCK_U_ITYPE_$C(30)
  1.  ;
  1. XVLCK 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
  1.  ;
  1. TST ;
  1.  D ADD("",2087425,6257016,"",28,"272741003|24028007")
  1.  Q
  1.  ;
  1. ADD(DATA,VIEN,DESCID,PRBIEN,PKIEN,LAT,PIPIEN) ;EP - BJPN SET PROB TO PIP
  1.  ;
  1.  ;This RPC adds the prenatal problem to the patient's PIP
  1.  ;
  1.  ;Input:  VIEN - Visit IEN
  1.  ;        DESCID - The Description Id of the Concept to Add
  1.  ;        PRBIEN - The Pointer to IPL - null if new IPL entry
  1.  ;         PKIEN - Pointer to 90362.34 entry
  1.  ;           LAT - Internal attribute|laterality value
  1.  ;        PIPIEN - The PIPIEN - if there override current problem and do not save new PIP entry
  1.  ;
  1.  NEW %,UID,II,CONCID,SMDDATA,ICD,P,B,C9,C8,PTEXT,ONSDT,ISTS,CLASS,NEXT,IPRI
  1.  NEW A,Q,XARRAY,IPOV,RESULT
  1.  ;
  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^BJPNPRL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
  1.  ;
  1.  S C9=$C(29)
  1.  S C8=$C(28)
  1.  ;
  1.  S @DATA@(II)="T00005RESULT^I00010PIPIEN^T00150ERROR_MESSAGE^I00010PRBIEN"_$C(30)
  1.  ;
  1.  ;Input validation
  1.  I $G(VIEN)="" S II=II+1,@DATA@(II)="-1^^MISSING VISIT NUMBER"_$C(30) G XADD
  1.  I $G(DESCID)="" S II=II+1,@DATA@(II)="-1^MISSING DESCRIPTION ID"_$C(30) G XADD
  1.  S PRBIEN=$G(PRBIEN) S:PRBIEN=0 PRBIEN=""
  1.  S PIPIEN=$G(PIPIEN) S:PIPIEN=0 PIPIEN=""
  1.  S LAT=$G(LAT)
  1.  ;
  1.  ;Get DFN
  1.  S DFN=$$GET1^DIQ(9000010,VIEN_",",".05","I")
  1.  ;
  1.  ;Get current date/time
  1.  D NOW^%DTC
  1.  ;
  1.  ;Concept ID
  1.  S SMDDATA=$$DESC^BSTSAPI(DESCID_"^^1")
  1.  S CONCID=$P(SMDDATA,U)
  1.  S ICD=$P(SMDDATA,U,3)
  1.  ;
  1.  ;Get current IPL problem info (if not new)
  1.  ;Array(n)="P" [1] ^ Problem Ien [2] ^ SNOMED CONCEPT ID [3] ^ SNOMED DESC ID[4] ^Number code [5] ^ Status [6]^
  1.  ;             Onset [7] ^ Prov Narrative [8] ^ ICD [9] ^ Priority [10] ^ Class [11] ^ PIP [12] ^ Additional ICD [13] ^
  1.  ;             inpt DX [14] ^Outpt DX ^^^^^Laterality [20]
  1.  ;Array(n)="A" [1] ^ Classification [2] ^ Control [3] ^ V asthma IEN [4]
  1.  ;Array(n)= "Q" [1] ^ TYPE [2] ^ IEN [3] ^ SNOMED [4] ^ Text [5]
  1.  ;
  1.  ;Set fields to default values
  1.  S (A,PTEXT,ONSDT,CLASS,IPRI,IPOV)="",ISTS="Episodic"
  1.  ;
  1.  ;BJPN*2.0*3;CR#03192;Honor Pick List Status
  1.  I +$G(PKIEN)>0,+$G(CONCID)>0 D
  1.  . NEW PKEN,STS
  1.  . S PKEN=$O(^BGOSNOPR(PKIEN,1,"B",CONCID,"")) Q:PKEN=""
  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 STS=$P($G(^BGOSNOPR(PKIEN,1,PKEN,0)),U,6) Q:STS=""
  1.  . I STS="P" S CLASS="P"
  1.  . ;
  1.  . ;Custom code to account for EHR bug
  1.  . S ISTS=$S(STS="A":"Chronic",STS="Sub-acute":"Sub-acute",STS="I":"Inactive",STS="E":"Episodic",STS="O":"Social/Environmental",STS="P":"Inactive",STS="R":"Admin",1:ISTS)
  1.  ;
  1.  ;Next problem number
  1.  D
  1.  . NEW RET
  1.  . D NEXTID^BGOPROB(.RET,DFN)
  1.  . S NEXT=+$P(RET,"-",2)
  1.  ;
  1.  ;If already on IPL, pull information from IPL entry and possibly override what came in
  1.  I +PRBIEN D
  1.  . NEW BGO,API,XDESC,XCONC,PNARR,XICD,XSTS,XCLASS,XNEXT,TMP
  1.  . D COMP^BJPNUTIL(DFN,UID,VIEN,PRBIEN)
  1.  . S TMP=$NA(^TMP("BJPNIPL",UID))  ;Define compiled data reference
  1.  . ;
  1.  . ;
  1.  . ;Retrieve the entry from the API results
  1.  . S BGO=$O(@TMP@("P",PRBIEN,"")) I BGO="" Q
  1.  . S API=$G(@TMP@("P",PRBIEN,BGO)) I API="" Q
  1.  . ;
  1.  . ;DESC ID - Override what came in
  1.  . I PIPIEN="" D  I (XCONC="")!(XDESC="") Q
  1.  .. S XDESC=$P(API,U,4) Q:XDESC=""
  1.  .. S XCONC=$P(API,U,3) Q:XCONC=""
  1.  .. S DESCID=XDESC,CONCID=XCONC
  1.  .. ;
  1.  .. ;Laterality
  1.  .. S LAT=$P(API,U,20)
  1.  . ;
  1.  . ;Provider Text
  1.  . S PNARR=$P(API,U,8)
  1.  . S PTEXT=$P(PNARR," | ",2)
  1.  . ;
  1.  . ;Mapped ICD
  1.  . S XICD=$P(API,U,9) S:XICD]"" ICD=XICD
  1.  . ;
  1.  . ;Get Onset Date
  1.  . S ONSDT=$P(API,U,7) S:ONSDT]"" ONSDT=$$DATE^BJPNPRUT($P(ONSDT," "))
  1.  . ;
  1.  . ;Get IPL Status
  1.  . S XSTS=$P(API,U,6),XSTS=$S(XSTS="CHRONIC":"Chronic",XSTS="INACTIVE":"Inactive",XSTS="DELETED":"Deleted",XSTS="SUB-ACUTE":"Sub-acute",XSTS="SOCIAL":"Social/Environmental",XSTS="EPISODIC":"Episodic",XSTS="ROUTINE/ADMIN":"Routine/Admin",1:"")
  1.  . S:XSTS]"" ISTS=XSTS
  1.  . ;
  1.  . ;Get Class
  1.  . S XCLASS=$P(API,U,11) S:XCLASS]"" CLASS=XCLASS
  1.  . ;
  1.  . ;Get number code
  1.  . S XNEXT=$P($P(API,U,5),"-",2) S:XNEXT]"" NEXT=XNEXT
  1.  . ;
  1.  . ;IPL Priority
  1.  . S IPRI=$P(API,U,10)
  1.  . ;
  1.  . ;Inpatient POV
  1.  . S IPOV=$P(API,U,14)
  1.  . ;
  1.  . ;Now get the Asthma Information
  1.  . ;
  1.  . ;Retrieve the entry from the API results
  1.  . S BGO=$O(@TMP@("A",PRBIEN,""))
  1.  . I BGO]"" S API=$G(@TMP@("A",PRBIEN,BGO,0)) I API]"" S A=$TR(API,"^",C9)
  1.  . ;
  1.  . ;Now get the qualifiers
  1.  . S BGO="" F  S BGO=$O(@TMP@("Q",PRBIEN,BGO)) Q:BGO=""  D
  1.  .. S API=$G(@TMP@("Q",PRBIEN,BGO,0)) Q:API=""
  1.  .. S Q(BGO)="Q"_C9_$P(API,U,2)_C9_$P(API,U,3)_C9_$P(API,U,4)_C9_C9_C9_"0"
  1.  ;
  1.  ;Input parameters:
  1.  ;     DFN - Patient IEN
  1.  ;  PRBIEN - IEN of IPL, null if new
  1.  ;  PIPIEN - IEN of PIP, null if new
  1.  ;    VIEN - Visit IEN
  1.  ;  IARRAY - Array of problem information - Records delimited by $c(28), fields by $c(29)
  1.  ;                                        - (R) Required, (O) Optional
  1.  ;Problem (IPL) entry (Required):
  1.  ;?P? [1] 29 Concept Id (R) [2] 29 Description Id (R) [3] 29 Provider Text (O) [4] 29 
  1.  ;Mapped ICD (R) [5] 29 Location (null for new) [6] 29 Date of Onset [7] 29
  1.  ;IPL Status (R) [8] 29 Class [9] 29 Problem # [10] 29 
  1.  ;Priority [11] 29 Inpatient_POV value (O) [12] Attribute|Laterality
  1.  ;
  1.  ;Asthma
  1.  ;"A"[1] 29 Classification [2] 29 Control (pass through value) [3] 29 V asthma IEN (pass through value) [4]
  1.  ;
  1.  ;Prenatal (PIP) entry (Required):
  1.  ;?B? [1] 29 PIP Status (R) [2] 29 PIP Scope (R) [3] 29 PIP Priority (O) [4] 29 Definitive EDD (O) [5]
  1.  ;
  1.  ;Qualifier Entry or Entries (Optional):
  1.  ;?Q? [1] 29 TYPE (S/C) (R) [2] 29 IEN (present for edits, null for new) (O) [3] 29 Concept Id of Entry (R) [4] 29
  1.  ;User (null for new) [5] 29 Date/time (null for new) [6] 29 Delete flag (1 ? Delete, otherwise ? 0) (R) [7]
  1.  ;
  1.  ;Assemble the IPL entry
  1.  S P="P"_C9_CONCID_C9_DESCID_C9_PTEXT_C9_ICD_C9_C9_ONSDT_C9_ISTS_C9_CLASS_C9_NEXT_C9_IPRI_C9_IPOV_C9_LAT
  1.  ;
  1.  ;Set up the 'B' PIP entry
  1.  S B="B"_C9_"A"_C9_"C"_C9_C9_$$GET1^DIQ(9000017,DFN_",",1311,"I")
  1.  ;
  1.  ;Assemble the array
  1.  ;
  1.  ;IPL and PIP sections
  1.  S XARRAY=P_C8_B
  1.  ;
  1.  ;Asthma
  1.  S:A]"" XARRAY=XARRAY_C8_A
  1.  ;
  1.  ;Qualifiers
  1.  S Q="" F  S Q=$O(Q(Q)) Q:Q=""  S XARRAY=XARRAY_C8_Q(Q)
  1.  ;
  1.  ;Add the problem
  1.  D SET^BJPNPSET("",DFN,PRBIEN,PIPIEN,VIEN,XARRAY)
  1.  ;
  1.  ;Get the result
  1.  S RESULT=$P($G(^TMP("BJPNPSET",UID,1)),$C(30))
  1.  ;
  1.  ;Log the result
  1.  S II=II+1,@DATA@(II)=$P(RESULT,U)_U_$P(RESULT,U,3)_U_$P(RESULT,U,4)_U_$P(RESULT,U,2)_$C(30)
  1.  ;
  1. XADD S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. STC(FIL,FLD,VAL) ;EP - Find a value for a set of codes code
  1.  ;  Input Parameters
  1.  ;    FIL = FileMan File Number
  1.  ;    FLD = FileMan Field Number
  1.  ;    VAL = Code Value
  1.  ;
  1.  NEW VEDATA,VEQFL,VEVL,VALUE
  1.  S VEDATA=$P(^DD(FIL,FLD,0),U,3),VEQFL=0
  1.  ;
  1.  F I=1:1 S VEVL=$P(VEDATA,";",I) Q:VEVL=""  D  Q:VEQFL
  1.  . S VALUE=$P(VEVL,":",2) I VAL=$P(VEVL,":",1) S VEQFL=1
  1.  ;
  1.  Q VALUE
  1.  ;
  1. FMTE(Y,FORMAT) ;EP - Convert Fileman Date/Time to 'MMM DD, CCYY HH:MM:SS' format.
  1.  ;Description
  1.  ;  Receives Date (Y) in FileMan format and returns formatted date.
  1.  ;
  1.  ;Input
  1.  ;  Y - FileMan date/time (i.e. 3051024.123456).
  1.  ;
  1.  ;Output
  1.  ;  Date/Time in External format (i.e. OCT 24,2005 12:34:56).
  1.  ;
  1.  NEW DATM,XX,I,V,X
  1.  I $G(FORMAT)="" D
  1.  .S DATM=$TR($$FMTE^DILIBF(Y,"5U"),"@"," ")
  1.  .I DATM["24:00" S DATM=$P(DATM," ",1,2)_" 00:00"
  1.  .S XX="" F I=1:1:$L(DATM) S V=$E(DATM,I,I),XX=XX_V I V="," S XX=XX_" "
  1.  .S DATM=XX
  1.  ;
  1.  I $G(FORMAT)]"" D
  1.  .S DATM=$$FMTE^XLFDT(Y,FORMAT)
  1.  ;
  1.  Q DATM
  1.  ;
  1. VNOTES(DATA,PIPIEN,VIEN) ;EP - BJPN CHK FOR VST NOTES
  1.  ;
  1.  ;This RPC returns whether the given problem has any notes on file for the
  1.  ;provided visit
  1.  ;
  1.  ;Input:
  1.  ; PIPIEN - Pointer to Prenatal Problem file entry
  1.  ; VIEN - The visit IEN
  1.  ;
  1.  ;Output:
  1.  ; 1 - Notes are present for the problem for the visit
  1.  ; 0 - No notes are present
  1.  ;
  1.  S PIPIEN=$G(PIPIEN,""),VIEN=$G(VIEN,"")
  1.  I PIPIEN="" S BMXSEC="INVALID PIP VALUE" Q
  1.  I VIEN=""  S BMXSEC="INVALID VIEN" Q
  1.  ;
  1.  NEW UID,II,DFN,CNT,FOUND
  1.  ;
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BJPNPDET",UID))
  1.  K @DATA
  1.  I $G(DT)=""!($G(U)="") D DT^DICRW
  1.  ;
  1.  ;S TMP=$NA(^TMP("BJPNPDET",UID))
  1.  ;K @TMP
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPDET D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
  1.  ;
  1.  ;Header
  1.  S @DATA@(II)="T00001NOTES_PRESENT"_$C(30)
  1.  ;
  1.  ;Retrieve DFN
  1.  S DFN=$$GET1^DIQ(90680.01,PIPIEN_",",.02,"I") I DFN="" S BMXSEC="INVALID PIPIEN/DFN" Q
  1.  ;
  1.  ;D NOTES^BJPNPRL("",DFN,PIPIEN,1)
  1.  ;
  1.  ;Loop through and check each note for visit
  1.  S (FOUND,CNT)=0 F  S CNT=$O(^TMP("BJPNPRL",$J,CNT)) Q:CNT=""  D  Q:FOUND
  1.  . NEW NODE,NVIEN
  1.  . S NODE=^TMP("BJPNPRL",$J,CNT)
  1.  . S NVIEN=$P(NODE,U,4) I VIEN'=NVIEN Q
  1.  . S FOUND=1
  1.  S II=II+1,@DATA@(II)=FOUND_$C(30)
  1.  ;
  1.  ;Cleanup
  1.  K ^TMP("BJPNPRL",$J)
  1.  ;
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. NOTES(DATA,DFN,PR,API) ;EP - BJPN GET PR NOTES
  1.  ;Tag no longer used
  1.  Q