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

BJPNPSET.m

Go to the documentation of this file. 
  1. BJPNPSET ;GDIT/HS/BEE-Prenatal Care Module Add/Edit Problem ; 08 May 2012  12:00 PM
  1.  ;;2.0;PRENATAL CARE MODULE;**3,6,7,8**;Feb 24, 2015;Build 25
  1.  ;
  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 [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]
  1.  ;?B? [1] 29 PIP Status (R) [2] 29 PIP Scope (R) [3] 29 PIP Priority (O) [4] 29 Definitive EDD (O) [5]
  1.  ;?Q? [1] 29 TYPE (S/C) (R) [2] 29 IEN (for edits) (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.  Q
  1.  ;
  1. SET(DATA,DFN,PRBIEN,PIPIEN,VIEN,IARRAY) ;EP - BJPN SET PROBLEM
  1.  ;
  1.  ;This RPC adds/edits a PIP problem
  1.  ;It also adds or updates the IPL problem entry, if necessary.
  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] 29 Laterality Attribute|Qualifier [13]
  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.  ;Output value
  1.  ;1^PRBIEN^PIPIEN - Success
  1.  ;-1^^ERROR MESSAGE - Failure
  1.  ;
  1.  NEW UID,II,ENTRY,ECNT,PIECE,ARRAY,C8,C9,A,B,P,Q,%,LIST,RET,NEWIPL,EDD,ONSDT,LSTCNT
  1.  ;
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BJPNPSET",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^BJPNPSET D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
  1.  ;
  1.  ;Define header
  1.  S @DATA@(0)="I00001RESULT^I00010PRBIEN^I00010PIPIEN^T00200ERROR_MESSAGE"_$C(30)
  1.  ;
  1.  ;Get the current date/time
  1.  D NOW^%DTC
  1.  ;
  1.  ;Check for input variables
  1.  I $G(DFN)="" S BMXSEC="Invalid DFN" G XSET
  1.  I $G(VIEN)="" S BMXSEC="Invalid VIEN" G XSET
  1.  S PRBIEN=$G(PRBIEN)
  1.  S PIPIEN=$G(PIPIEN)
  1.  ;
  1.  ;Parse the input array
  1.  S (B,P)="",C8=$C(28),C9=$C(29)
  1.  ;
  1.  F ECNT=1:1:$L(IARRAY,C8) S ENTRY=$P(IARRAY,C8,ECNT) D
  1.  . NEW ETYPE,IPRTY
  1.  . S ETYPE=$P(ENTRY,C9)
  1.  . ;
  1.  . ;Set up problem entry
  1.  . I ETYPE="P" D  Q
  1.  .. NEW LOC,ONSET,CLASS,ISTS,PRBCNT
  1.  .. S P="P"
  1.  .. S $P(P,U,2)=$P(ENTRY,C9,2)  ;Concept Id
  1.  .. S $P(P,U,3)=$P(ENTRY,C9,3)  ;Description Id
  1.  .. S $P(P,U,4)=$P(ENTRY,C9,4)  ;Provider Text
  1.  .. S $P(P,U,5)=$P(ENTRY,C9,5)  ;ICD Code
  1.  .. ;
  1.  .. ;Get the location
  1.  .. S LOC="" I PRBIEN]"" S LOC=$$GET1^DIQ(9000011,PRBIEN_",",.06,"E")
  1.  .. S:LOC="" LOC=$$GET1^DIQ(9000010,VIEN_",",".06","I")
  1.  .. S $P(P,U,6)=LOC
  1.  .. ;
  1.  .. ;Convert the Date of Onset to internal
  1.  .. S ONSDT=$P(ENTRY,C9,7) D:ONSDT]""
  1.  ... NEW MONTH
  1.  ... I ONSDT?4N S ONSDT="3"_$E(ONSDT,3,4)_"0000" Q  ;Year only
  1.  ... I $L(ONSDT,"/")=2 D  Q  ;Month and Year
  1.  .... S:$L($P(ONSDT,"/"))=1 ONSDT="0"_ONSDT
  1.  .... S ONSDT="3"_$E($P(ONSDT,"/",2),3,4)_$P(ONSDT,"/")_"00" Q  ;Month/Year
  1.  ... S:ONSDT]"" ONSDT=$$DATE^BJPNPRUT($P(ONSDT," "))
  1.  .. S $P(P,U,7)=ONSDT
  1.  .. ;
  1.  .. ;IPL Status
  1.  .. S ISTS=$P(ENTRY,C9,8)
  1.  .. I ISTS="",PRBIEN]"" S ISTS=$$GET1^DIQ(9000011,PRBIEN_",",.12,"E")
  1.  .. I ISTS="" S ISTS="Episodic"
  1.  .. S $P(P,U,8)=ISTS
  1.  .. ;
  1.  .. ;If existing problem, get CLASS
  1.  .. S CLASS=$P(ENTRY,C9,9)
  1.  .. I CLASS="",PRBIEN]"",PIPIEN="" S CLASS=$$GET1^DIQ(9000011,PRBIEN_",",.04,"I")
  1.  .. I CLASS="",PIPIEN]"" S CLASS="@"
  1.  .. S $P(P,U,9)=CLASS
  1.  .. ;
  1.  .. ;Problem number - Get the next one if not an edit
  1.  .. S PRBCNT=$P(P,U,1) S:PRBCNT["-" PRBCNT=+$P(PRBCNT,"-",2)
  1.  .. I PRBCNT="",PRBIEN]"" S PRBCNT=$$GET1^DIQ(9000011,PRBIEN_",",.07,"I")
  1.  .. I PRBCNT="" D
  1.  ... NEW RET
  1.  ... D NEXTID^BGOPROB(.RET,DFN)
  1.  ... S PRBCNT=+$P(RET,"-",2)
  1.  .. S $P(P,U,10)=PRBCNT
  1.  .. ;
  1.  .. ;IPL Priority
  1.  .. S IPRTY=$P(ENTRY,C9,11)
  1.  .. I IPRTY="",PRBIEN]"" D
  1.  ... NEW PRIEN
  1.  ... S PRIEN=$O(^BGOPROB("B",PRBIEN,"")) Q:PRIEN=""
  1.  ... S IPRTY=$$GET1^DIQ(90362.22,PRIEN_",",.02,"I")
  1.  .. S:IPRTY="" IPRTY=0
  1.  .. S $P(P,U,11)=IPRTY
  1.  .. ;
  1.  .. ;BJPN*2.0*7;Added laterality
  1.  .. S $P(P,U,13)=$P(ENTRY,C9,13)
  1.  .. ;
  1.  .. ;Inpatient Dx
  1.  .. S $P(P,U,12)=$S($P(ENTRY,C9,12)="Y":1,1:0)
  1.  . ;
  1.  . ;Set up PIP entry
  1.  . I ETYPE="B" D  Q
  1.  .. S B=$TR(ENTRY,C9,"^")
  1.  . ;
  1.  . ;Set up Asthma entry
  1.  . I ETYPE="A" D  Q
  1.  .. S A=$TR(ENTRY,C9,"^")
  1.  . ;
  1.  . ;Define qualifiers
  1.  . I ETYPE="Q" D  Q
  1.  .. S Q=$G(Q)+1
  1.  .. S Q(Q)=$TR(ENTRY,C9,"^")
  1.  .. S:$P(Q(Q),U,5)="" $P(Q(Q),U,5)=DUZ
  1.  .. S:$P(Q(Q),U,6)="" $P(Q(Q),U,6)=%
  1.  ;
  1.  ;Set up the array
  1.  I P="" S BMXSEC="Missing IPL problem entry" G XSET
  1.  I B="" S BMXSEC="Missing PIP problem entry" G XSET
  1.  ;
  1.  ;Convert the DEDD to internal
  1.  ;S EDD=$P(B,U,5)  ;Always pull from reproductive factors
  1.  S EDD=$$GET1^DIQ(9000017,DFN_",",1311,"I") I 1
  1.  E  I EDD]"" S EDD=$$DATE^BJPNPRUT(EDD)
  1.  S $P(B,U,5)=EDD
  1.  ;
  1.  S LSTCNT=0
  1.  S LIST(0)=P
  1.  I $G(A)]"" S LSTCNT=LSTCNT+1,LIST(LSTCNT)=A
  1.  S Q="" F  S Q=$O(Q(Q)) Q:Q=""  S LSTCNT=LSTCNT+1,LIST(LSTCNT)=Q(Q)
  1.  ;
  1.  ;File the IPL entry
  1.  ;
  1.  ;New problem
  1.  S NEWIPL=0
  1.  I PRBIEN="" D  I $G(BMXSEC)]"" G XSET
  1.  . ;
  1.  . ;Log the IPL problem
  1.  . S NEWIPL=1
  1.  . D SET^BGOPROB(.RET,DFN,"",VIEN,.LIST)
  1.  . I +RET S PRBIEN=+RET
  1.  . ;
  1.  . ;Now log the PIP problem
  1.  . I +RET S RET=$$ADDPIP(DFN,+RET,B)
  1.  . I +RET S PIPIEN=+RET
  1.  ;
  1.  ;Existing problem
  1.  I 'NEWIPL D  I $G(BMXSEC)]"" G XSET
  1.  . ;
  1.  . ;Edit the problem
  1.  . NEW RES1
  1.  . D EDIT^BGOPROB1(.RET,DFN,PRBIEN,VIEN,.LIST)
  1.  . I '$P(P,U,12) S RES1="" D HOSP^BGOHOS(.RES1,PRBIEN,VIEN,1) ;Remove inpatient checkbox if necessary
  1.  . ;
  1.  . ;If a new PIP entry, log it
  1.  . I '+$G(PIPIEN) D  Q
  1.  .. S RET=$$ADDPIP(DFN,PRBIEN,B)
  1.  .. I +RET S PIPIEN=+RET
  1.  . ;
  1.  . ;If not a new PIP entry, perform edit
  1.  . I +$G(PIPIEN) D  Q
  1.  .. S RET=$$EDTPIP(PRBIEN,PIPIEN,B)
  1.  ;
  1.  ;Update the IPL PIP column
  1.  I PRBIEN]"" D
  1.  . NEW PRBUPD,ERROR,PIP
  1.  . S PIP=$$GET1^DIQ(9000011,PRBIEN_",",.19,"I")
  1.  . I PIP=$S($P(B,U,2)="A":1,1:"") Q   ;Skip if already the same value
  1.  . S PRBUPD(9000011,PRBIEN_",",".19")=$S($P(B,U,2)="A":1,1:"@")
  1.  . D FILE^DIE("","PRBUPD","ERROR")
  1.  ;
  1.  ;Assemble return piece
  1.  I +$G(PRBIEN),+$G(PIPIEN) S RET="1^"_PRBIEN_U_PIPIEN
  1.  E  S RET="-1^^Unable to create new IPL/PIP entry"
  1.  S II=II+1,@DATA@(II)=RET_$C(30)
  1.  ;
  1.  ;Broadcast update
  1.  ;D FIREEV^BJPNPDET("","REFRESH")
  1.  ;BJPN*2.0*6;Do not fire since event fired from within EHR API
  1.  ;D FIREEV^BJPNPDET("","PCC."_DFN_".PPL")
  1.  ;D FIREEV^BJPNPDET("","PCC."_DFN_".PIP")
  1.  ;
  1. XSET S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. ADDPIP(DFN,PRBIEN,B) ;EP - Add PIP entry
  1.  ;
  1.  NEW %,DA,IENS,DIC,DLAYGO,X,Y,LASTIEN,NEXTIEN,BJPNPIP,ERROR,PIPIEN,BJPNPIPF
  1.  ;
  1.  ;Get current date/time
  1.  D NOW^%DTC
  1.  ;
  1.  ;Lock the header so duplicates aren't logged
  1.  L +^BJPNPL(0):2 I '$T S BMXSEC="Could not lock header node" Q -1
  1.  ;
  1.  ;Get the next available IEN
  1.  S LASTIEN=$O(^BJPNPL("A"),-1) I 'LASTIEN S ^BJPNPL(0)="BJPN PRENATAL PROBLEMS^90680.01I^"
  1.  F NEXTIEN=LASTIEN+1:1 I '$D(^BJPNPL(NEXTIEN)) D LOCK^DILF("^BJPNPL(NEXTIEN)") I  Q:'$D(^BJPNPL(NEXTIEN))  L -^BJPNPL(NEXTIEN)
  1.  ;
  1.  ;Add new entry
  1.  S DIC="^BJPNPL("
  1.  S DLAYGO=90680.01,DIC(0)="LOX"
  1.  S X=NEXTIEN
  1.  K DO,DD D FILE^DICN
  1.  ;
  1.  ;Unlock header
  1.  L -^BJPNPL(0)
  1.  ;
  1.  ;BJPN*2.0*7;Unlock entry
  1.  L -^BJPNPL(NEXTIEN)
  1.  ;
  1.  ;Quit if filing issue
  1.  I +Y=-1 S BMXSEC="Could not add new PIP entry" Q -1
  1.  ;
  1.  S PIPIEN=+Y
  1.  ;
  1.  ;File the PIP related entries
  1.  S BJPNPIP(90680.01,PIPIEN_",",.02)=DFN        ;DFN
  1.  S BJPNPIP(90680.01,PIPIEN_",",.06)=$P(B,U,4)  ;Priority
  1.  S BJPNPIP(90680.01,PIPIEN_",",.07)=$P(B,U,3)  ;Scope
  1.  S BJPNPIP(90680.01,PIPIEN_",",.08)=$P(B,U,2)  ;Status
  1.  S BJPNPIP(90680.01,PIPIEN_",",.09)=$P(B,U,5)  ;DEDD
  1.  S BJPNPIP(90680.01,PIPIEN_",",.1)=PRBIEN      ;IPL IEN
  1.  D FILE^DIE("","BJPNPIP","ERROR")
  1.  I $D(ERROR) S BMXSEC="Could not add values to new PIP entry" Q -1
  1.  ;
  1.  ;Add the IPL PIP flag
  1.  S DIC="^BJPNPL("_PIPIEN_",5,"
  1.  S DA(1)=PIPIEN
  1.  S DLAYGO="90680.015",DIC("P")=$P(^DD(90680.01,5,0),U,2),DIC(0)="LOX"
  1.  S X=%
  1.  K DO,DD D FILE^DICN
  1.  I +Y=-1 S BMXSEC="Could not add PIP column history" Q -1
  1.  ;
  1.  ;Add the User/PIP value
  1.  S DA(1)=PIPIEN,DA=+Y,IENS=$$IENS^DILF(.DA)
  1.  S BJPNPIPF(90680.015,IENS,".02")=$S($P(B,U,2)="A":1,1:0)
  1.  S BJPNPIPF(90680.015,IENS,".03")=DUZ
  1.  D FILE^DIE("","BJPNPIPF","ERROR")
  1.  I $D(ERROR) S BMXSEC="Could not add PIP column history fields" Q -1
  1.  Q PIPIEN
  1.  ;
  1. EDTPIP(PRBIEN,PIPIEN,B) ;EP - Edit PIP entry
  1.  ;
  1.  NEW %,BJPNPIP,ERROR,STATUS,SCOPE,DEDD,PRI,PIP
  1.  ;
  1.  ;Get current date/time
  1.  D NOW^%DTC
  1.  ;
  1.  ;Get current values
  1.  S PRI=$$GET1^DIQ(90680.01,PIPIEN_",",.06,"I")
  1.  S SCOPE=$$GET1^DIQ(90680.01,PIPIEN_",",.07,"I")
  1.  S STATUS=$$GET1^DIQ(90680.01,PIPIEN_",",".08","I")
  1.  S DEDD=$$GET1^DIQ(90680.01,PIPIEN_",",.09,"I")
  1.  S PIP=$$GET1^DIQ(9000011,PRBIEN_",",.19,"I"),PIP=$S(PIP="1":"A",1:"I")
  1.  ;
  1.  ;File the PIP related entries
  1.  S:PRI'=$P(B,U,4) BJPNPIP(90680.01,PIPIEN_",",.06)=$P(B,U,4)  ;Priority
  1.  S:SCOPE'=$P(B,U,3) BJPNPIP(90680.01,PIPIEN_",",.07)=$P(B,U,3)  ;Scope
  1.  S:STATUS'=$P(B,U,2) BJPNPIP(90680.01,PIPIEN_",",.08)=$P(B,U,2)  ;Status
  1.  S:DEDD'=$P(B,U,5) BJPNPIP(90680.01,PIPIEN_",",.09)=$P(B,U,5)  ;DEDD
  1.  I $D(BJPNPIP)>9 D FILE^DIE("","BJPNPIP","ERROR")
  1.  I $D(ERROR) S BMXSEC="Could not update values to new PIP entry" Q -1
  1.  ;
  1.  ;Update the IPL PIP flag if the status changed
  1.  I $P(B,U,2)'=PIP D  I $G(BMXSEC)]"" Q -1
  1.  . NEW DIC,DA,DLAYGO,X,Y,BJPNPIPF,ERROR,IENS
  1.  . S DIC="^BJPNPL("_PIPIEN_",5,"
  1.  . S DA(1)=PIPIEN
  1.  . S DLAYGO="90680.015",DIC("P")=$P(^DD(90680.01,5,0),U,2),DIC(0)="LOX"
  1.  . S X=%
  1.  . K DO,DD D FILE^DICN
  1.  . I +Y=-1 S BMXSEC="Could not add PIP column history" Q
  1.  . ;
  1.  . ;Add the User/PIP value
  1.  . S DA(1)=PIPIEN,DA=+Y,IENS=$$IENS^DILF(.DA)
  1.  . S BJPNPIPF(90680.015,IENS,".02")=$S($P(B,U,2)="A":1,1:0)
  1.  . S BJPNPIPF(90680.015,IENS,".03")=DUZ
  1.  . D FILE^DIE("","BJPNPIPF","ERROR")
  1.  . I $D(ERROR) S BMXSEC="Could not add PIP column history fields"
  1.  Q PIPIEN
  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