BJPNPSET ;GDIT/HS/BEE-Prenatal Care Module Add/Edit Problem ; 08 May 2012 12:00 PM
;;2.0;PRENATAL CARE MODULE;**3,6,7,8**;Feb 24, 2015;Build 25
;
;?P? [1] 29 Concept Id (R) [2] 29 Description Id (R) [3] 29 Provider Text (O) [4] 29
;Mapped ICD (R) [5] 29 Location [6] 29 Date of Onset [7] 29
;IPL Status (R) [8] 29 Class [9] 29 Problem # [10] 29
;Priority [11] 29 Inpatient_POV value (O) [12]
;?B? [1] 29 PIP Status (R) [2] 29 PIP Scope (R) [3] 29 PIP Priority (O) [4] 29 Definitive EDD (O) [5]
;?Q? [1] 29 TYPE (S/C) (R) [2] 29 IEN (for edits) (O) [3] 29 Concept Id of Entry (R) [4] 29
;User (null for new) [5] 29 Date/time (null for new) [6] 29 Delete flag (1 ? Delete, otherwise ? 0) (R) [7]
;
Q
;
SET(DATA,DFN,PRBIEN,PIPIEN,VIEN,IARRAY) ;EP - BJPN SET PROBLEM
;
;This RPC adds/edits a PIP problem
;It also adds or updates the IPL problem entry, if necessary.
;
;Input parameters:
; DFN - Patient IEN
; PRBIEN - IEN of IPL, null if new
; PIPIEN - IEN of PIP, null if new
; VIEN - Visit IEN
; IARRAY - Array of problem information - Records delimited by $c(28), fields by $c(29)
; - (R) Required, (O) Optional
;Problem (IPL) entry (Required):
;?P? [1] 29 Concept Id (R) [2] 29 Description Id (R) [3] 29 Provider Text (O) [4] 29
;Mapped ICD (R) [5] 29 Location (null for new) [6] 29 Date of Onset [7] 29
;IPL Status (R) [8] 29 Class [9] 29 Problem # [10] 29
;Priority [11] 29 Inpatient_POV value (O) [12] 29 Laterality Attribute|Qualifier [13]
;
;Asthma
;"A"[1] 29 Classification [2] 29 Control (pass through value) [3] 29 V asthma IEN (pass through value) [4]
;
;Prenatal (PIP) entry (Required):
;?B? [1] 29 PIP Status (R) [2] 29 PIP Scope (R) [3] 29 PIP Priority (O) [4] 29 Definitive EDD (O) [5]
;
;Qualifier Entry or Entries (Optional):
;?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
;User (null for new) [5] 29 Date/time (null for new) [6] 29 Delete flag (1 ? Delete, otherwise ? 0) (R) [7]
;
;Output value
;1^PRBIEN^PIPIEN - Success
;-1^^ERROR MESSAGE - Failure
;
NEW UID,II,ENTRY,ECNT,PIECE,ARRAY,C8,C9,A,B,P,Q,%,LIST,RET,NEWIPL,EDD,ONSDT,LSTCNT
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPSET",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPSET D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define header
S @DATA@(0)="I00001RESULT^I00010PRBIEN^I00010PIPIEN^T00200ERROR_MESSAGE"_$C(30)
;
;Get the current date/time
D NOW^%DTC
;
;Check for input variables
I $G(DFN)="" S BMXSEC="Invalid DFN" G XSET
I $G(VIEN)="" S BMXSEC="Invalid VIEN" G XSET
S PRBIEN=$G(PRBIEN)
S PIPIEN=$G(PIPIEN)
;
;Parse the input array
S (B,P)="",C8=$C(28),C9=$C(29)
;
F ECNT=1:1:$L(IARRAY,C8) S ENTRY=$P(IARRAY,C8,ECNT) D
. NEW ETYPE,IPRTY
. S ETYPE=$P(ENTRY,C9)
. ;
. ;Set up problem entry
. I ETYPE="P" D Q
.. NEW LOC,ONSET,CLASS,ISTS,PRBCNT
.. S P="P"
.. S $P(P,U,2)=$P(ENTRY,C9,2) ;Concept Id
.. S $P(P,U,3)=$P(ENTRY,C9,3) ;Description Id
.. S $P(P,U,4)=$P(ENTRY,C9,4) ;Provider Text
.. S $P(P,U,5)=$P(ENTRY,C9,5) ;ICD Code
.. ;
.. ;Get the location
.. S LOC="" I PRBIEN]"" S LOC=$$GET1^DIQ(9000011,PRBIEN_",",.06,"E")
.. S:LOC="" LOC=$$GET1^DIQ(9000010,VIEN_",",".06","I")
.. S $P(P,U,6)=LOC
.. ;
.. ;Convert the Date of Onset to internal
.. S ONSDT=$P(ENTRY,C9,7) D:ONSDT]""
... NEW MONTH
... I ONSDT?4N S ONSDT="3"_$E(ONSDT,3,4)_"0000" Q ;Year only
... I $L(ONSDT,"/")=2 D Q ;Month and Year
.... S:$L($P(ONSDT,"/"))=1 ONSDT="0"_ONSDT
.... S ONSDT="3"_$E($P(ONSDT,"/",2),3,4)_$P(ONSDT,"/")_"00" Q ;Month/Year
... S:ONSDT]"" ONSDT=$$DATE^BJPNPRUT($P(ONSDT," "))
.. S $P(P,U,7)=ONSDT
.. ;
.. ;IPL Status
.. S ISTS=$P(ENTRY,C9,8)
.. I ISTS="",PRBIEN]"" S ISTS=$$GET1^DIQ(9000011,PRBIEN_",",.12,"E")
.. I ISTS="" S ISTS="Episodic"
.. S $P(P,U,8)=ISTS
.. ;
.. ;If existing problem, get CLASS
.. S CLASS=$P(ENTRY,C9,9)
.. I CLASS="",PRBIEN]"",PIPIEN="" S CLASS=$$GET1^DIQ(9000011,PRBIEN_",",.04,"I")
.. I CLASS="",PIPIEN]"" S CLASS="@"
.. S $P(P,U,9)=CLASS
.. ;
.. ;Problem number - Get the next one if not an edit
.. S PRBCNT=$P(P,U,1) S:PRBCNT["-" PRBCNT=+$P(PRBCNT,"-",2)
.. I PRBCNT="",PRBIEN]"" S PRBCNT=$$GET1^DIQ(9000011,PRBIEN_",",.07,"I")
.. I PRBCNT="" D
... NEW RET
... D NEXTID^BGOPROB(.RET,DFN)
... S PRBCNT=+$P(RET,"-",2)
.. S $P(P,U,10)=PRBCNT
.. ;
.. ;IPL Priority
.. S IPRTY=$P(ENTRY,C9,11)
.. I IPRTY="",PRBIEN]"" D
... NEW PRIEN
... S PRIEN=$O(^BGOPROB("B",PRBIEN,"")) Q:PRIEN=""
... S IPRTY=$$GET1^DIQ(90362.22,PRIEN_",",.02,"I")
.. S:IPRTY="" IPRTY=0
.. S $P(P,U,11)=IPRTY
.. ;
.. ;BJPN*2.0*7;Added laterality
.. S $P(P,U,13)=$P(ENTRY,C9,13)
.. ;
.. ;Inpatient Dx
.. S $P(P,U,12)=$S($P(ENTRY,C9,12)="Y":1,1:0)
. ;
. ;Set up PIP entry
. I ETYPE="B" D Q
.. S B=$TR(ENTRY,C9,"^")
. ;
. ;Set up Asthma entry
. I ETYPE="A" D Q
.. S A=$TR(ENTRY,C9,"^")
. ;
. ;Define qualifiers
. I ETYPE="Q" D Q
.. S Q=$G(Q)+1
.. S Q(Q)=$TR(ENTRY,C9,"^")
.. S:$P(Q(Q),U,5)="" $P(Q(Q),U,5)=DUZ
.. S:$P(Q(Q),U,6)="" $P(Q(Q),U,6)=%
;
;Set up the array
I P="" S BMXSEC="Missing IPL problem entry" G XSET
I B="" S BMXSEC="Missing PIP problem entry" G XSET
;
;Convert the DEDD to internal
;S EDD=$P(B,U,5) ;Always pull from reproductive factors
S EDD=$$GET1^DIQ(9000017,DFN_",",1311,"I") I 1
E I EDD]"" S EDD=$$DATE^BJPNPRUT(EDD)
S $P(B,U,5)=EDD
;
S LSTCNT=0
S LIST(0)=P
I $G(A)]"" S LSTCNT=LSTCNT+1,LIST(LSTCNT)=A
S Q="" F S Q=$O(Q(Q)) Q:Q="" S LSTCNT=LSTCNT+1,LIST(LSTCNT)=Q(Q)
;
;File the IPL entry
;
;New problem
S NEWIPL=0
I PRBIEN="" D I $G(BMXSEC)]"" G XSET
. ;
. ;Log the IPL problem
. S NEWIPL=1
. D SET^BGOPROB(.RET,DFN,"",VIEN,.LIST)
. I +RET S PRBIEN=+RET
. ;
. ;Now log the PIP problem
. I +RET S RET=$$ADDPIP(DFN,+RET,B)
. I +RET S PIPIEN=+RET
;
;Existing problem
I 'NEWIPL D I $G(BMXSEC)]"" G XSET
. ;
. ;Edit the problem
. NEW RES1
. D EDIT^BGOPROB1(.RET,DFN,PRBIEN,VIEN,.LIST)
. I '$P(P,U,12) S RES1="" D HOSP^BGOHOS(.RES1,PRBIEN,VIEN,1) ;Remove inpatient checkbox if necessary
. ;
. ;If a new PIP entry, log it
. I '+$G(PIPIEN) D Q
.. S RET=$$ADDPIP(DFN,PRBIEN,B)
.. I +RET S PIPIEN=+RET
. ;
. ;If not a new PIP entry, perform edit
. I +$G(PIPIEN) D Q
.. S RET=$$EDTPIP(PRBIEN,PIPIEN,B)
;
;Update the IPL PIP column
I PRBIEN]"" D
. NEW PRBUPD,ERROR,PIP
. S PIP=$$GET1^DIQ(9000011,PRBIEN_",",.19,"I")
. I PIP=$S($P(B,U,2)="A":1,1:"") Q ;Skip if already the same value
. S PRBUPD(9000011,PRBIEN_",",".19")=$S($P(B,U,2)="A":1,1:"@")
. D FILE^DIE("","PRBUPD","ERROR")
;
;Assemble return piece
I +$G(PRBIEN),+$G(PIPIEN) S RET="1^"_PRBIEN_U_PIPIEN
E S RET="-1^^Unable to create new IPL/PIP entry"
S II=II+1,@DATA@(II)=RET_$C(30)
;
;Broadcast update
;D FIREEV^BJPNPDET("","REFRESH")
;BJPN*2.0*6;Do not fire since event fired from within EHR API
;D FIREEV^BJPNPDET("","PCC."_DFN_".PPL")
;D FIREEV^BJPNPDET("","PCC."_DFN_".PIP")
;
XSET S II=II+1,@DATA@(II)=$C(31)
Q
;
ADDPIP(DFN,PRBIEN,B) ;EP - Add PIP entry
;
NEW %,DA,IENS,DIC,DLAYGO,X,Y,LASTIEN,NEXTIEN,BJPNPIP,ERROR,PIPIEN,BJPNPIPF
;
;Get current date/time
D NOW^%DTC
;
;Lock the header so duplicates aren't logged
L +^BJPNPL(0):2 I '$T S BMXSEC="Could not lock header node" Q -1
;
;Get the next available IEN
S LASTIEN=$O(^BJPNPL("A"),-1) I 'LASTIEN S ^BJPNPL(0)="BJPN PRENATAL PROBLEMS^90680.01I^"
F NEXTIEN=LASTIEN+1:1 I '$D(^BJPNPL(NEXTIEN)) D LOCK^DILF("^BJPNPL(NEXTIEN)") I Q:'$D(^BJPNPL(NEXTIEN)) L -^BJPNPL(NEXTIEN)
;
;Add new entry
S DIC="^BJPNPL("
S DLAYGO=90680.01,DIC(0)="LOX"
S X=NEXTIEN
K DO,DD D FILE^DICN
;
;Unlock header
L -^BJPNPL(0)
;
;BJPN*2.0*7;Unlock entry
L -^BJPNPL(NEXTIEN)
;
;Quit if filing issue
I +Y=-1 S BMXSEC="Could not add new PIP entry" Q -1
;
S PIPIEN=+Y
;
;File the PIP related entries
S BJPNPIP(90680.01,PIPIEN_",",.02)=DFN ;DFN
S BJPNPIP(90680.01,PIPIEN_",",.06)=$P(B,U,4) ;Priority
S BJPNPIP(90680.01,PIPIEN_",",.07)=$P(B,U,3) ;Scope
S BJPNPIP(90680.01,PIPIEN_",",.08)=$P(B,U,2) ;Status
S BJPNPIP(90680.01,PIPIEN_",",.09)=$P(B,U,5) ;DEDD
S BJPNPIP(90680.01,PIPIEN_",",.1)=PRBIEN ;IPL IEN
D FILE^DIE("","BJPNPIP","ERROR")
I $D(ERROR) S BMXSEC="Could not add values to new PIP entry" Q -1
;
;Add the IPL PIP flag
S DIC="^BJPNPL("_PIPIEN_",5,"
S DA(1)=PIPIEN
S DLAYGO="90680.015",DIC("P")=$P(^DD(90680.01,5,0),U,2),DIC(0)="LOX"
S X=%
K DO,DD D FILE^DICN
I +Y=-1 S BMXSEC="Could not add PIP column history" Q -1
;
;Add the User/PIP value
S DA(1)=PIPIEN,DA=+Y,IENS=$$IENS^DILF(.DA)
S BJPNPIPF(90680.015,IENS,".02")=$S($P(B,U,2)="A":1,1:0)
S BJPNPIPF(90680.015,IENS,".03")=DUZ
D FILE^DIE("","BJPNPIPF","ERROR")
I $D(ERROR) S BMXSEC="Could not add PIP column history fields" Q -1
Q PIPIEN
;
EDTPIP(PRBIEN,PIPIEN,B) ;EP - Edit PIP entry
;
NEW %,BJPNPIP,ERROR,STATUS,SCOPE,DEDD,PRI,PIP
;
;Get current date/time
D NOW^%DTC
;
;Get current values
S PRI=$$GET1^DIQ(90680.01,PIPIEN_",",.06,"I")
S SCOPE=$$GET1^DIQ(90680.01,PIPIEN_",",.07,"I")
S STATUS=$$GET1^DIQ(90680.01,PIPIEN_",",".08","I")
S DEDD=$$GET1^DIQ(90680.01,PIPIEN_",",.09,"I")
S PIP=$$GET1^DIQ(9000011,PRBIEN_",",.19,"I"),PIP=$S(PIP="1":"A",1:"I")
;
;File the PIP related entries
S:PRI'=$P(B,U,4) BJPNPIP(90680.01,PIPIEN_",",.06)=$P(B,U,4) ;Priority
S:SCOPE'=$P(B,U,3) BJPNPIP(90680.01,PIPIEN_",",.07)=$P(B,U,3) ;Scope
S:STATUS'=$P(B,U,2) BJPNPIP(90680.01,PIPIEN_",",.08)=$P(B,U,2) ;Status
S:DEDD'=$P(B,U,5) BJPNPIP(90680.01,PIPIEN_",",.09)=$P(B,U,5) ;DEDD
I $D(BJPNPIP)>9 D FILE^DIE("","BJPNPIP","ERROR")
I $D(ERROR) S BMXSEC="Could not update values to new PIP entry" Q -1
;
;Update the IPL PIP flag if the status changed
I $P(B,U,2)'=PIP D I $G(BMXSEC)]"" Q -1
. NEW DIC,DA,DLAYGO,X,Y,BJPNPIPF,ERROR,IENS
. S DIC="^BJPNPL("_PIPIEN_",5,"
. S DA(1)=PIPIEN
. S DLAYGO="90680.015",DIC("P")=$P(^DD(90680.01,5,0),U,2),DIC(0)="LOX"
. S X=%
. K DO,DD D FILE^DICN
. I +Y=-1 S BMXSEC="Could not add PIP column history" Q
. ;
. ;Add the User/PIP value
. S DA(1)=PIPIEN,DA=+Y,IENS=$$IENS^DILF(.DA)
. S BJPNPIPF(90680.015,IENS,".02")=$S($P(B,U,2)="A":1,1:0)
. S BJPNPIPF(90680.015,IENS,".03")=DUZ
. D FILE^DIE("","BJPNPIPF","ERROR")
. I $D(ERROR) S BMXSEC="Could not add PIP column history fields"
Q PIPIEN
;
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
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
+2 ;
+3 ;?P? [1] 29 Concept Id (R) [2] 29 Description Id (R) [3] 29 Provider Text (O) [4] 29
+4 ;Mapped ICD (R) [5] 29 Location [6] 29 Date of Onset [7] 29
+5 ;IPL Status (R) [8] 29 Class [9] 29 Problem # [10] 29
+6 ;Priority [11] 29 Inpatient_POV value (O) [12]
+7 ;?B? [1] 29 PIP Status (R) [2] 29 PIP Scope (R) [3] 29 PIP Priority (O) [4] 29 Definitive EDD (O) [5]
+8 ;?Q? [1] 29 TYPE (S/C) (R) [2] 29 IEN (for edits) (O) [3] 29 Concept Id of Entry (R) [4] 29
+9 ;User (null for new) [5] 29 Date/time (null for new) [6] 29 Delete flag (1 ? Delete, otherwise ? 0) (R) [7]
+10 ;
+11 QUIT
+12 ;
SET(DATA,DFN,PRBIEN,PIPIEN,VIEN,IARRAY) ;EP - BJPN SET PROBLEM
+1 ;
+2 ;This RPC adds/edits a PIP problem
+3 ;It also adds or updates the IPL problem entry, if necessary.
+4 ;
+5 ;Input parameters:
+6 ; DFN - Patient IEN
+7 ; PRBIEN - IEN of IPL, null if new
+8 ; PIPIEN - IEN of PIP, null if new
+9 ; VIEN - Visit IEN
+10 ; IARRAY - Array of problem information - Records delimited by $c(28), fields by $c(29)
+11 ; - (R) Required, (O) Optional
+12 ;Problem (IPL) entry (Required):
+13 ;?P? [1] 29 Concept Id (R) [2] 29 Description Id (R) [3] 29 Provider Text (O) [4] 29
+14 ;Mapped ICD (R) [5] 29 Location (null for new) [6] 29 Date of Onset [7] 29
+15 ;IPL Status (R) [8] 29 Class [9] 29 Problem # [10] 29
+16 ;Priority [11] 29 Inpatient_POV value (O) [12] 29 Laterality Attribute|Qualifier [13]
+17 ;
+18 ;Asthma
+19 ;"A"[1] 29 Classification [2] 29 Control (pass through value) [3] 29 V asthma IEN (pass through value) [4]
+20 ;
+21 ;Prenatal (PIP) entry (Required):
+22 ;?B? [1] 29 PIP Status (R) [2] 29 PIP Scope (R) [3] 29 PIP Priority (O) [4] 29 Definitive EDD (O) [5]
+23 ;
+24 ;Qualifier Entry or Entries (Optional):
+25 ;?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
+26 ;User (null for new) [5] 29 Date/time (null for new) [6] 29 Delete flag (1 ? Delete, otherwise ? 0) (R) [7]
+27 ;
+28 ;Output value
+29 ;1^PRBIEN^PIPIEN - Success
+30 ;-1^^ERROR MESSAGE - Failure
+31 ;
+32 NEW UID,II,ENTRY,ECNT,PIECE,ARRAY,C8,C9,A,B,P,Q,%,LIST,RET,NEWIPL,EDD,ONSDT,LSTCNT
+33 ;
+34 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+35 SET DATA=$NAME(^TMP("BJPNPSET",UID))
+36 KILL @DATA
+37 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+38 ;
+39 SET II=0
+40 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPSET D UNWIND^%ZTER"
+41 ;
+42 ;Define header
+43 SET @DATA@(0)="I00001RESULT^I00010PRBIEN^I00010PIPIEN^T00200ERROR_MESSAGE"_$CHAR(30)
+44 ;
+45 ;Get the current date/time
+46 DO NOW^%DTC
+47 ;
+48 ;Check for input variables
+49 IF $GET(DFN)=""
SET BMXSEC="Invalid DFN"
GOTO XSET
+50 IF $GET(VIEN)=""
SET BMXSEC="Invalid VIEN"
GOTO XSET
+51 SET PRBIEN=$GET(PRBIEN)
+52 SET PIPIEN=$GET(PIPIEN)
+53 ;
+54 ;Parse the input array
+55 SET (B,P)=""
SET C8=$CHAR(28)
SET C9=$CHAR(29)
+56 ;
+57 FOR ECNT=1:1:$LENGTH(IARRAY,C8)
SET ENTRY=$PIECE(IARRAY,C8,ECNT)
Begin DoDot:1
+58 NEW ETYPE,IPRTY
+59 SET ETYPE=$PIECE(ENTRY,C9)
+60 ;
+61 ;Set up problem entry
+62 IF ETYPE="P"
Begin DoDot:2
+63 NEW LOC,ONSET,CLASS,ISTS,PRBCNT
+64 SET P="P"
+65 ;Concept Id
SET $PIECE(P,U,2)=$PIECE(ENTRY,C9,2)
+66 ;Description Id
SET $PIECE(P,U,3)=$PIECE(ENTRY,C9,3)
+67 ;Provider Text
SET $PIECE(P,U,4)=$PIECE(ENTRY,C9,4)
+68 ;ICD Code
SET $PIECE(P,U,5)=$PIECE(ENTRY,C9,5)
+69 ;
+70 ;Get the location
+71 SET LOC=""
IF PRBIEN]""
SET LOC=$$GET1^DIQ(9000011,PRBIEN_",",.06,"E")
+72 IF LOC=""
SET LOC=$$GET1^DIQ(9000010,VIEN_",",".06","I")
+73 SET $PIECE(P,U,6)=LOC
+74 ;
+75 ;Convert the Date of Onset to internal
+76 SET ONSDT=$PIECE(ENTRY,C9,7)
IF ONSDT]""
Begin DoDot:3
+77 NEW MONTH
+78 ;Year only
IF ONSDT?4N
SET ONSDT="3"_$EXTRACT(ONSDT,3,4)_"0000"
QUIT
+79 ;Month and Year
IF $LENGTH(ONSDT,"/")=2
Begin DoDot:4
+80 IF $LENGTH($PIECE(ONSDT,"/"))=1
SET ONSDT="0"_ONSDT
+81 ;Month/Year
SET ONSDT="3"_$EXTRACT($PIECE(ONSDT,"/",2),3,4)_$PIECE(ONSDT,"/")_"00"
QUIT
End DoDot:4
QUIT
+82 IF ONSDT]""
SET ONSDT=$$DATE^BJPNPRUT($PIECE(ONSDT," "))
End DoDot:3
+83 SET $PIECE(P,U,7)=ONSDT
+84 ;
+85 ;IPL Status
+86 SET ISTS=$PIECE(ENTRY,C9,8)
+87 IF ISTS=""
IF PRBIEN]""
SET ISTS=$$GET1^DIQ(9000011,PRBIEN_",",.12,"E")
+88 IF ISTS=""
SET ISTS="Episodic"
+89 SET $PIECE(P,U,8)=ISTS
+90 ;
+91 ;If existing problem, get CLASS
+92 SET CLASS=$PIECE(ENTRY,C9,9)
+93 IF CLASS=""
IF PRBIEN]""
IF PIPIEN=""
SET CLASS=$$GET1^DIQ(9000011,PRBIEN_",",.04,"I")
+94 IF CLASS=""
IF PIPIEN]""
SET CLASS="@"
+95 SET $PIECE(P,U,9)=CLASS
+96 ;
+97 ;Problem number - Get the next one if not an edit
+98 SET PRBCNT=$PIECE(P,U,1)
IF PRBCNT["-"
SET PRBCNT=+$PIECE(PRBCNT,"-",2)
+99 IF PRBCNT=""
IF PRBIEN]""
SET PRBCNT=$$GET1^DIQ(9000011,PRBIEN_",",.07,"I")
+100 IF PRBCNT=""
Begin DoDot:3
+101 NEW RET
+102 DO NEXTID^BGOPROB(.RET,DFN)
+103 SET PRBCNT=+$PIECE(RET,"-",2)
End DoDot:3
+104 SET $PIECE(P,U,10)=PRBCNT
+105 ;
+106 ;IPL Priority
+107 SET IPRTY=$PIECE(ENTRY,C9,11)
+108 IF IPRTY=""
IF PRBIEN]""
Begin DoDot:3
+109 NEW PRIEN
+110 SET PRIEN=$ORDER(^BGOPROB("B",PRBIEN,""))
IF PRIEN=""
QUIT
+111 SET IPRTY=$$GET1^DIQ(90362.22,PRIEN_",",.02,"I")
End DoDot:3
+112 IF IPRTY=""
SET IPRTY=0
+113 SET $PIECE(P,U,11)=IPRTY
+114 ;
+115 ;BJPN*2.0*7;Added laterality
+116 SET $PIECE(P,U,13)=$PIECE(ENTRY,C9,13)
+117 ;
+118 ;Inpatient Dx
+119 SET $PIECE(P,U,12)=$SELECT($PIECE(ENTRY,C9,12)="Y":1,1:0)
End DoDot:2
QUIT
+120 ;
+121 ;Set up PIP entry
+122 IF ETYPE="B"
Begin DoDot:2
+123 SET B=$TRANSLATE(ENTRY,C9,"^")
End DoDot:2
QUIT
+124 ;
+125 ;Set up Asthma entry
+126 IF ETYPE="A"
Begin DoDot:2
+127 SET A=$TRANSLATE(ENTRY,C9,"^")
End DoDot:2
QUIT
+128 ;
+129 ;Define qualifiers
+130 IF ETYPE="Q"
Begin DoDot:2
+131 SET Q=$GET(Q)+1
+132 SET Q(Q)=$TRANSLATE(ENTRY,C9,"^")
+133 IF $PIECE(Q(Q),U,5)=""
SET $PIECE(Q(Q),U,5)=DUZ
+134 IF $PIECE(Q(Q),U,6)=""
SET $PIECE(Q(Q),U,6)=%
End DoDot:2
QUIT
End DoDot:1
+135 ;
+136 ;Set up the array
+137 IF P=""
SET BMXSEC="Missing IPL problem entry"
GOTO XSET
+138 IF B=""
SET BMXSEC="Missing PIP problem entry"
GOTO XSET
+139 ;
+140 ;Convert the DEDD to internal
+141 ;S EDD=$P(B,U,5) ;Always pull from reproductive factors
+142 SET EDD=$$GET1^DIQ(9000017,DFN_",",1311,"I")
IF 1
+143 IF '$TEST
IF EDD]""
SET EDD=$$DATE^BJPNPRUT(EDD)
+144 SET $PIECE(B,U,5)=EDD
+145 ;
+146 SET LSTCNT=0
+147 SET LIST(0)=P
+148 IF $GET(A)]""
SET LSTCNT=LSTCNT+1
SET LIST(LSTCNT)=A
+149 SET Q=""
FOR
SET Q=$ORDER(Q(Q))
IF Q=""
QUIT
SET LSTCNT=LSTCNT+1
SET LIST(LSTCNT)=Q(Q)
+150 ;
+151 ;File the IPL entry
+152 ;
+153 ;New problem
+154 SET NEWIPL=0
+155 IF PRBIEN=""
Begin DoDot:1
+156 ;
+157 ;Log the IPL problem
+158 SET NEWIPL=1
+159 DO SET^BGOPROB(.RET,DFN,"",VIEN,.LIST)
+160 IF +RET
SET PRBIEN=+RET
+161 ;
+162 ;Now log the PIP problem
+163 IF +RET
SET RET=$$ADDPIP(DFN,+RET,B)
+164 IF +RET
SET PIPIEN=+RET
End DoDot:1
IF $GET(BMXSEC)]""
GOTO XSET
+165 ;
+166 ;Existing problem
+167 IF 'NEWIPL
Begin DoDot:1
+168 ;
+169 ;Edit the problem
+170 NEW RES1
+171 DO EDIT^BGOPROB1(.RET,DFN,PRBIEN,VIEN,.LIST)
+172 ;Remove inpatient checkbox if necessary
IF '$PIECE(P,U,12)
SET RES1=""
DO HOSP^BGOHOS(.RES1,PRBIEN,VIEN,1)
+173 ;
+174 ;If a new PIP entry, log it
+175 IF '+$GET(PIPIEN)
Begin DoDot:2
+176 SET RET=$$ADDPIP(DFN,PRBIEN,B)
+177 IF +RET
SET PIPIEN=+RET
End DoDot:2
QUIT
+178 ;
+179 ;If not a new PIP entry, perform edit
+180 IF +$GET(PIPIEN)
Begin DoDot:2
+181 SET RET=$$EDTPIP(PRBIEN,PIPIEN,B)
End DoDot:2
QUIT
End DoDot:1
IF $GET(BMXSEC)]""
GOTO XSET
+182 ;
+183 ;Update the IPL PIP column
+184 IF PRBIEN]""
Begin DoDot:1
+185 NEW PRBUPD,ERROR,PIP
+186 SET PIP=$$GET1^DIQ(9000011,PRBIEN_",",.19,"I")
+187 ;Skip if already the same value
IF PIP=$SELECT($PIECE(B,U,2)="A":1,1:"")
QUIT
+188 SET PRBUPD(9000011,PRBIEN_",",".19")=$SELECT($PIECE(B,U,2)="A":1,1:"@")
+189 DO FILE^DIE("","PRBUPD","ERROR")
End DoDot:1
+190 ;
+191 ;Assemble return piece
+192 IF +$GET(PRBIEN)
IF +$GET(PIPIEN)
SET RET="1^"_PRBIEN_U_PIPIEN
+193 IF '$TEST
SET RET="-1^^Unable to create new IPL/PIP entry"
+194 SET II=II+1
SET @DATA@(II)=RET_$CHAR(30)
+195 ;
+196 ;Broadcast update
+197 ;D FIREEV^BJPNPDET("","REFRESH")
+198 ;BJPN*2.0*6;Do not fire since event fired from within EHR API
+199 ;D FIREEV^BJPNPDET("","PCC."_DFN_".PPL")
+200 ;D FIREEV^BJPNPDET("","PCC."_DFN_".PIP")
+201 ;
XSET SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
ADDPIP(DFN,PRBIEN,B) ;EP - Add PIP entry
+1 ;
+2 NEW %,DA,IENS,DIC,DLAYGO,X,Y,LASTIEN,NEXTIEN,BJPNPIP,ERROR,PIPIEN,BJPNPIPF
+3 ;
+4 ;Get current date/time
+5 DO NOW^%DTC
+6 ;
+7 ;Lock the header so duplicates aren't logged
+8 LOCK +^BJPNPL(0):2
IF '$TEST
SET BMXSEC="Could not lock header node"
QUIT -1
+9 ;
+10 ;Get the next available IEN
+11 SET LASTIEN=$ORDER(^BJPNPL("A"),-1)
IF 'LASTIEN
SET ^BJPNPL(0)="BJPN PRENATAL PROBLEMS^90680.01I^"
+12 FOR NEXTIEN=LASTIEN+1:1
IF '$DATA(^BJPNPL(NEXTIEN))
DO LOCK^DILF("^BJPNPL(NEXTIEN)")
IF $TEST
IF '$DATA(^BJPNPL(NEXTIEN))
QUIT
LOCK -^BJPNPL(NEXTIEN)
+13 ;
+14 ;Add new entry
+15 SET DIC="^BJPNPL("
+16 SET DLAYGO=90680.01
SET DIC(0)="LOX"
+17 SET X=NEXTIEN
+18 KILL DO,DD
DO FILE^DICN
+19 ;
+20 ;Unlock header
+21 LOCK -^BJPNPL(0)
+22 ;
+23 ;BJPN*2.0*7;Unlock entry
+24 LOCK -^BJPNPL(NEXTIEN)
+25 ;
+26 ;Quit if filing issue
+27 IF +Y=-1
SET BMXSEC="Could not add new PIP entry"
QUIT -1
+28 ;
+29 SET PIPIEN=+Y
+30 ;
+31 ;File the PIP related entries
+32 ;DFN
SET BJPNPIP(90680.01,PIPIEN_",",.02)=DFN
+33 ;Priority
SET BJPNPIP(90680.01,PIPIEN_",",.06)=$PIECE(B,U,4)
+34 ;Scope
SET BJPNPIP(90680.01,PIPIEN_",",.07)=$PIECE(B,U,3)
+35 ;Status
SET BJPNPIP(90680.01,PIPIEN_",",.08)=$PIECE(B,U,2)
+36 ;DEDD
SET BJPNPIP(90680.01,PIPIEN_",",.09)=$PIECE(B,U,5)
+37 ;IPL IEN
SET BJPNPIP(90680.01,PIPIEN_",",.1)=PRBIEN
+38 DO FILE^DIE("","BJPNPIP","ERROR")
+39 IF $DATA(ERROR)
SET BMXSEC="Could not add values to new PIP entry"
QUIT -1
+40 ;
+41 ;Add the IPL PIP flag
+42 SET DIC="^BJPNPL("_PIPIEN_",5,"
+43 SET DA(1)=PIPIEN
+44 SET DLAYGO="90680.015"
SET DIC("P")=$PIECE(^DD(90680.01,5,0),U,2)
SET DIC(0)="LOX"
+45 SET X=%
+46 KILL DO,DD
DO FILE^DICN
+47 IF +Y=-1
SET BMXSEC="Could not add PIP column history"
QUIT -1
+48 ;
+49 ;Add the User/PIP value
+50 SET DA(1)=PIPIEN
SET DA=+Y
SET IENS=$$IENS^DILF(.DA)
+51 SET BJPNPIPF(90680.015,IENS,".02")=$SELECT($PIECE(B,U,2)="A":1,1:0)
+52 SET BJPNPIPF(90680.015,IENS,".03")=DUZ
+53 DO FILE^DIE("","BJPNPIPF","ERROR")
+54 IF $DATA(ERROR)
SET BMXSEC="Could not add PIP column history fields"
QUIT -1
+55 QUIT PIPIEN
+56 ;
EDTPIP(PRBIEN,PIPIEN,B) ;EP - Edit PIP entry
+1 ;
+2 NEW %,BJPNPIP,ERROR,STATUS,SCOPE,DEDD,PRI,PIP
+3 ;
+4 ;Get current date/time
+5 DO NOW^%DTC
+6 ;
+7 ;Get current values
+8 SET PRI=$$GET1^DIQ(90680.01,PIPIEN_",",.06,"I")
+9 SET SCOPE=$$GET1^DIQ(90680.01,PIPIEN_",",.07,"I")
+10 SET STATUS=$$GET1^DIQ(90680.01,PIPIEN_",",".08","I")
+11 SET DEDD=$$GET1^DIQ(90680.01,PIPIEN_",",.09,"I")
+12 SET PIP=$$GET1^DIQ(9000011,PRBIEN_",",.19,"I")
SET PIP=$SELECT(PIP="1":"A",1:"I")
+13 ;
+14 ;File the PIP related entries
+15 ;Priority
IF PRI'=$PIECE(B,U,4)
SET BJPNPIP(90680.01,PIPIEN_",",.06)=$PIECE(B,U,4)
+16 ;Scope
IF SCOPE'=$PIECE(B,U,3)
SET BJPNPIP(90680.01,PIPIEN_",",.07)=$PIECE(B,U,3)
+17 ;Status
IF STATUS'=$PIECE(B,U,2)
SET BJPNPIP(90680.01,PIPIEN_",",.08)=$PIECE(B,U,2)
+18 ;DEDD
IF DEDD'=$PIECE(B,U,5)
SET BJPNPIP(90680.01,PIPIEN_",",.09)=$PIECE(B,U,5)
+19 IF $DATA(BJPNPIP)>9
DO FILE^DIE("","BJPNPIP","ERROR")
+20 IF $DATA(ERROR)
SET BMXSEC="Could not update values to new PIP entry"
QUIT -1
+21 ;
+22 ;Update the IPL PIP flag if the status changed
+23 IF $PIECE(B,U,2)'=PIP
Begin DoDot:1
+24 NEW DIC,DA,DLAYGO,X,Y,BJPNPIPF,ERROR,IENS
+25 SET DIC="^BJPNPL("_PIPIEN_",5,"
+26 SET DA(1)=PIPIEN
+27 SET DLAYGO="90680.015"
SET DIC("P")=$PIECE(^DD(90680.01,5,0),U,2)
SET DIC(0)="LOX"
+28 SET X=%
+29 KILL DO,DD
DO FILE^DICN
+30 IF +Y=-1
SET BMXSEC="Could not add PIP column history"
QUIT
+31 ;
+32 ;Add the User/PIP value
+33 SET DA(1)=PIPIEN
SET DA=+Y
SET IENS=$$IENS^DILF(.DA)
+34 SET BJPNPIPF(90680.015,IENS,".02")=$SELECT($PIECE(B,U,2)="A":1,1:0)
+35 SET BJPNPIPF(90680.015,IENS,".03")=DUZ
+36 DO FILE^DIE("","BJPNPIPF","ERROR")
+37 IF $DATA(ERROR)
SET BMXSEC="Could not add PIP column history fields"
End DoDot:1
IF $GET(BMXSEC)]""
QUIT -1
+38 QUIT PIPIEN
+39 ;
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
