BJPNPDET ;GDIT/HS/BEE-Prenatal Care Module Utility 2 Calls ; 08 May 2012 12:00 PM
;;2.0;PRENATAL CARE MODULE;;Feb 24, 2015;Build 63
;
Q
;
DET(DATA,PIP) ;EP - BJPN PROBLEM DETAIL
;
;This RPC returns the problem detail for a Problem entry (including paste deletes)
;
;Input:
; PIP - Pointer to Prenatal Problem file entry
;
NEW UID,II,TMP,REC,PLIEN,DFN,TERM,PIPIEN
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPDET",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S TMP=$NA(^TMP("BJPNPDT1",UID))
K @TMP
;
S II=0,REC=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPDET D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define Header
S @DATA@(II)="T01024REPORT_TEXT"_$C(30)
;
S II=II+1,@DATA@(II)="This will eventually be filled with detail history"_$C(30)
G XDET
I $G(PIP)="" G XDET
;
;Retrieve Problem Pointer
S PLIEN=$$GET1^DIQ(90680.01,PIP_",",.03,"I") I PLIEN="" G XDET
;
;Retrieve DFN
S DFN=$$GET1^DIQ(90680.01,PIP_",",.02,"I") I DFN="" G XDET
;
S TERM=$$GET1^DIQ(90680.02,PLIEN_",",.02,"E")
;
;Loop through all instances of problem (including deletes)
S PIPIEN="" F S PIPIEN=$O(^BJPNPL("AC",DFN,PLIEN,PIPIEN)) Q:'PIPIEN D
. ;
. NEW VDT
. ;Step through all V OB entries for PIPIEN
. S REC=0,VDT="" F S VDT=$O(^AUPNVOB("AE",DFN,PIPIEN,VDT)) Q:VDT="" D
.. ;
.. NEW VFIEN
.. S VFIEN="" F S VFIEN=$O(^AUPNVOB("AE",DFN,PIPIEN,VDT,VFIEN)) Q:VFIEN="" D
... ;
... NEW ALMDT,LMDT,LMBY,OEDT,OEBY,AIEN
... ;
... ;Pull LMDT
... S ALMDT=$$GET1^DIQ(9000010.43,VFIEN_",",1218,"I")
... S:ALMDT="" ALMDT=$$GET1^DIQ(9000010.43,VFIEN_",",1216,"I")
... ;
... ;Loop through audit history
... S AIEN=0 F S AIEN=$O(^AUPNVOB(VFIEN,22,AIEN)) Q:'AIEN D
.... ;
.... NEW DA,IENS,RCNT,DA,IENS,ATYP,AVAL,VALUE,RCNT,VIEN
.... ;
.... S DA(1)=VFIEN,DA=AIEN,IENS=$$IENS^DILF(.DA)
.... S ATYP=$$GET1^DIQ(9000010.4311,IENS,".01","I")
.... S AVAL=$$GET1^DIQ(9000010.4311,IENS,".02","I")
.... ;
.... ;Define Line
.... S VALUE=$$VALUE(VFIEN,ATYP,AVAL)
.... ;
.... ;Date/User Handling
.... I AVAL=1216 S OEDT=VALUE Q
.... I AVAL=1217 S OEBY=VALUE Q
.... I AVAL=1218 S LMDT=VALUE Q
.... I AVAL=1219 S LMBY=VALUE Q
.... ;
.... ;Log entry
.... F RCNT=1:1:$L(VALUE,$C(28)) S REC=REC+1,@TMP@(ALMDT,REC)=$P(VALUE,$C(28),RCNT)
... ;
... ;Log Date/User
... I $G(LMDT)]"" S REC=REC+1,@TMP@(ALMDT,REC)=LMDT
... I $G(LMBY)]"" S REC=REC+1,@TMP@(ALMDT,REC)=LMBY
... I $G(OEDT)]"" S REC=REC+1,@TMP@(ALMDT,REC)=OEDT
... I $G(OEBY)]"" S REC=REC+1,@TMP@(ALMDT,REC)=OEBY
... ;
... ;Visit Date
... S VIEN=$$GET1^DIQ(9000010.43,VFIEN,.03,"I")
... S REC=REC+1,@TMP@(ALMDT,REC)=" *Visit Date: "_$$FMTE^BJPNPRL($$GET1^DIQ(9000010,VIEN_",",.01,"I"))
... ;
... ;Insert blank line
... S REC=REC+1,@TMP@(ALMDT,REC)=""
;
;Assemble Header
S II=II+1,@DATA@(II)="SNOMED Term: "_TERM_$C(13)_$C(10)
S II=II+1,@DATA@(II)=$C(13)_$C(10)
;
;Current Info
S II=II+1,@DATA@(II)="CURRENT INFORMATION"_$C(13)_$C(10)
S II=II+1,@DATA@(II)=$C(13)_$C(10)
S II=II+1,@DATA@(II)=" *Provider Text: "_$$GET1^DIQ(90680.01,PIP_",",.05,"E")_$C(13)_$C(10)
S II=II+1,@DATA@(II)=" *Priority: "_$$GET1^DIQ(90680.01,PIP_",",.06,"E")_$C(13)_$C(10)
S II=II+1,@DATA@(II)=" *Scope: "_$$GET1^DIQ(90680.01,PIP_",",.07,"E")_$C(13)_$C(10)
S II=II+1,@DATA@(II)=" *Status: "_$$GET1^DIQ(90680.01,PIP_",",.08,"E")_$C(13)_$C(10)
S II=II+1,@DATA@(II)=" *Definitive EDD: "_$$FMTE^BJPNPRL($$GET1^DIQ(90680.01,PIP_",",.09,"I"))_$C(13)_$C(10)
S II=II+1,@DATA@(II)=" *Current Note: "_$$GET1^DIQ(90680.01,PIP_",",3,"E")_$C(13)_$C(10)
S II=II+1,@DATA@(II)=$C(13)_$C(10)
S II=II+1,@DATA@(II)="PROBLEM HISTORY"_$C(13)_$C(10)
S II=II+1,@DATA@(II)=$C(13)_$C(10)
;
;Loop through results and format
NEW VDT
S VDT="" F S VDT=$O(@TMP@(VDT),-1) Q:VDT="" D
. NEW REC
. S REC="" F S REC=$O(@TMP@(VDT,REC)) Q:REC="" D
.. S II=II+1,@DATA@(II)=@TMP@(VDT,REC)_$C(13)_$C(10)
S II=II+1,@DATA@(II)=$C(30)
;
XDET K @TMP
S II=II+1,@DATA@(II)=$C(31)
Q
;
VALUE(VFIEN,ATYP,AVAL) ;EP - Retrieve field value
;
I $G(VFIEN)="" Q ""
I $G(ATYP)="" Q ""
I $G(AVAL)="" Q ""
;
S VALUE=""
;
;Audit Header
I ATYP="C" Q AVAL
;
;SNOMED Term
I AVAL=".12" D Q VALUE
. NEW PKIEN,TERM
. S PKIEN=$$GET1^DIQ(9000010.43,VFIEN_",",.12,"I") Q:PKIEN=""
. S VALUE=" *Set SNOMED Term to: "_$$GET1^DIQ(90680.02,PKIEN_",",.02,"E")
;
;Used as POV
I AVAL=".05" D Q VALUE
. NEW POV
. S POV=$$GET1^DIQ(9000010.43,VFIEN_",",.05,"E")
. S VALUE=" *Set As POV set to: "_$S(POV]"":POV,1:"No")
;
;Priority
I AVAL=".06" D Q VALUE
. NEW PRI
. S PRI=$$GET1^DIQ(9000010.43,VFIEN_",",.06,"E")
. S VALUE=" *Priority set to: "_$S(PRI]"":PRI,1:"<Not Set>")
;
;Provider Text
I AVAL=".07" D Q VALUE
. NEW PTX
. S PTX=$$GET1^DIQ(9000010.43,VFIEN_",",.07,"E")
. S VALUE=" *Provider Text set to: "_$S(PTX]"":PTX,1:"<Not Set>")
;
;Scope
I AVAL=".08" D Q VALUE
. NEW SCO
. S SCO=$$GET1^DIQ(9000010.43,VFIEN_",",.08,"E")
. S VALUE=" *Scope set to: "_$S(SCO]"":SCO,1:"<Not Set>")
;
;Status
I AVAL=".09" D Q VALUE
. NEW STS
. S STS=$$GET1^DIQ(9000010.43,VFIEN_",",.09,"E")
. S VALUE=" *Status set to: "_$S(STS]"":STS,1:"<Not Set>")
;
;DEDD
I AVAL=".1" D Q VALUE
. NEW DEDD
. S DEDD=$$GET1^DIQ(9000010.43,VFIEN_",",.1,"E")
. S VALUE=" *Definitive EDD set to: "_$S(DEDD]"":DEDD,1:"<Not Set>")
;
;Provider Narrative
I AVAL=".11" D Q VALUE
. NEW PNAR
. S PNAR=$$GET1^DIQ(9000010.43,VFIEN_",",.11,"E")
. S VALUE=" *Provider Narrative set to: "_$S(PNAR]"":PNAR,1:"<Not Set>")
;
;Original Entry Date
I AVAL="1216" D Q VALUE
. NEW OEDT
. S OEDT=$$GET1^DIQ(9000010.43,VFIEN_",",1216,"I")
. S OEDT=$$FMTE^BJPNPRL(OEDT)
. S VALUE=" *Original Entry Date: "_OEDT
;
;Original Entered By
I AVAL="1217" D Q VALUE
. NEW OEBY
. S OEBY=$$GET1^DIQ(9000010.43,VFIEN_",",1217,"E")
. S VALUE=" *Original Entered By: "_OEBY
;
;Last Modified Dt
I AVAL="1218" D Q VALUE
. NEW LMDT
. S LMDT=$$GET1^DIQ(9000010.43,VFIEN_",",1218,"I")
. S LMDT=$$FMTE^BJPNPRL(LMDT)
. S VALUE=" *Entry Modified On: "_LMDT
;
;Last Modified By
I AVAL="1219" D Q VALUE
. NEW LMBY
. S LMBY=$$GET1^DIQ(9000010.43,VFIEN_",",1219,"E")
. S VALUE=" *Entry Modified By: "_LMBY
;
;Problem Deleted By
I AVAL="2.01" D Q VALUE
. NEW PDBY
. S PDBY=$$GET1^DIQ(9000010.43,VFIEN_",",2.01,"E")
. S VALUE=" *Problem Deleted By: "_$S(PDBY]"":PDBY,1:"<Not Set>")
;
I AVAL="2.02" D Q VALUE
. NEW PDDT
. S PDDT=$$GET1^DIQ(9000010.43,VFIEN_",",2.02,"I")
. S PDDT=$$FMTE^BJPNPRL(PDDT)
. S VALUE=" *Problem Deleted On: "_$S(PDDT]"":PDDT,1:"<Not Set>")
;
;Delete Code
I AVAL="2.03" D Q VALUE
. NEW DCOD
. S DCOD=$$GET1^DIQ(9000010.43,VFIEN_",",2.03,"E")
. S VALUE=" *Problem Delete Reason: "_$S(DCOD]"":DCOD,1:"<Not Set>")
;
;Delete Reason
I AVAL="2.04" D Q VALUE
. NEW DRSN
. S DRSN=$$GET1^DIQ(9000010.43,VFIEN_",",2.04,"E")
. S VALUE=" *Problem Delete Reason: "_$S(DRSN]"":DRSN,1:"<Not Set>")
;
;Problem Note Additions
I $P(AVAL,":")=2100,$P(AVAL,":",4)'="D" D Q VALUE
. NEW NOTE,DA,IENS
. S DA(1)=VFIEN,DA=$P(AVAL,":",2),IENS=$$IENS^DILF(.DA)
. S VALUE=$$GET1^DIQ(9000010.431,IENS,.01,"E")
. S:VALUE]"" VALUE=" *Note Added: "_VALUE
;
;Problem Note Deletions
I $P(AVAL,":")=2100,$P(AVAL,":",4)="D" D Q VALUE
. NEW NOTE,DA,IENS,VAL
. S VALUE=""
. S DA(1)=$P(AVAL,":",2),DA=$P(AVAL,":",3),IENS=$$IENS^DILF(.DA)
. S VAL=$$GET1^DIQ(9000010.431,IENS,.01,"E")
. S:VAL]"" VALUE=" *Note Deleted: "_VAL
. ;
. ;Deleted On
. S VAL=$$FMTE^BJPNPRL($$GET1^DIQ(9000010.431,IENS,2.02,"I"))
. S:VAL]"" VALUE=VALUE_$S(VALUE]"":$C(28),1:"")_" *Note Deleted On: "_VAL
. ;
. ;Deleted By
. S VAL=$$GET1^DIQ(9000010.431,IENS,2.01,"E")
. S:VAL]"" VALUE=VALUE_$S(VALUE]"":$C(28),1:"")_" *Note Deleted By: "_VAL
. ;
. ;Delete Code
. S VAL=$$GET1^DIQ(9000010.431,IENS,2.03,"E")
. S:VAL]"" VALUE=VALUE_$S(VALUE]"":$C(28),1:"")_" *Note Deletion Code: "_VAL
. ;
. ;Delete Reason
. S VAL=$$GET1^DIQ(9000010.431,IENS,2.04,"E")
. S:VAL]"" VALUE=VALUE_$S(VALUE]"":$C(28),1:"")_" *Note Deletion Reason: "_VAL
;
Q AVAL
;
EDIT(DATA,DFN) ;EP - BJPN CAN EDIT PIP
;
;This RPC returns whether the PIP can be edited
;
;Input:
; DFN - Patient IEN
;
NEW UID,II,KEY,RET,X1,X2,X
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPDET",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPDET D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define Header
S @DATA@(II)="T00001CAN_EDIT^T00100VIEW_ONLY_REASON"_$C(30)
;
;Key Check
S KEY=0 D
. I $$HASKEY^CIAVCXUS("ORES",DUZ) S KEY=1 Q
. I $$HASKEY^CIAVCXUS("PROVIDER",DUZ) S KEY=1 Q
. I $$HASKEY^CIAVCXUS("ORELSE",DUZ) S KEY=1 Q
. I $$HASKEY^CIAVCXUS("BGOZ PROBLEM LIST EDIT",DUZ) S KEY=1 Q
. I $$HASKEY^CIAVCXUS("BGOZ VIEW ONLY",DUZ) S KEY=1
I KEY=0 S II=II+1,@DATA@(II)="1^USER DOES NOT HOLD THE APPROPRIATE KEY(S) TO VIEW/EDIT"_$C(30) G XEDIT
;
;Parameter check
I $$HASKEY^CIAVCXUS("@BJPN DISABLE PRENATAL EDITING",DUZ) D G XEDIT
. S II=II+1,@DATA@(II)="3^USER OR USER CLASS FOUND IN BJPN DISABLE PRENATAL EDITING"_$C(30)
;
;BGOZ VIEW ONLY key check
I $$HASKEY^CIAVCXUS("BGOZ VIEW ONLY",DUZ) S II=II+1,@DATA@(II)="2^USER HOLDS THE BGOZ VIEW ONLY KEY"_$C(30) G XEDIT
;
;Definitive EDD checks
;
S DEDD=$$DEDD(DFN)
S:DEDD="" DEDD=$$GET1^DIQ(9000017,DFN_",",1311,"I")
I DEDD="" D G XEDIT
. S II=II+1,@DATA@(II)="4^NO CURRENT OR PAST DEFINITIVE EDD FOUND"_$C(30)
;
;Definitive EDD date range check
D GETPAR^CIAVMRPC(.RET,"BJPN POST DEDD DAYS","SYS",1,"I","")
;
;If blank default to 70
I +RET<1 S RET=70
;
;Check range
S X1=DEDD,X2=-280 D C^%DTC
I DEDD>0,DT<X S II=II+1,@DATA@(II)="5^TODAYS DATE IS EARLIER THAN ALLOWABLE EDIT RANGE"_$C(30) G XEDIT
S X1=DEDD,X2=RET D C^%DTC
I DEDD>0,DT>X S II=II+1,@DATA@(II)="6^TODAYS DATE IS GREATER THAN ALLOWABLE POST RANGE"_$C(30) G XEDIT
;
S II=II+1,@DATA@(II)="0^"_$C(30)
;
XEDIT S II=II+1,@DATA@(II)=$C(31)
Q
;
DEDD(DFN) ;EP - Return Last Definitive EDD
;
NEW PIPIEN,DEDD
;
I $G(DFN)="" Q ""
;
;Loop through problems and find last DEDD
S (DEDD,PIPIEN)="" F S PIPIEN=$O(^BJPNPL("D",DFN,PIPIEN)) Q:'PIPIEN D Q:DEDD
. ;
. ;Skip deletes
. I $$GET1^DIQ(90680.01,PIPIEN_",",2.01,"I")]"" Q
. ;
. ;Pull DEDD
. S DEDD=$$GET1^DIQ(90680.01,PIPIEN_",",.09,"I")
Q DEDD
;
FIREEV(DATA,TYPE,STUB,LST,AID,XUSER) ;EP - BJPN FIRE EHR EVENT
;
;This RPC will fire the passed event in EHR
;
;Input:
; TYPE - Event Type to Broadcast (ex. PCC.<dfn>.PIP)
; STUB - Event Stub (optional)
; LST - Recipient List (optional)
; AID - Application ID (optional)
; XUSER - If 1, do not include user in event fire
;
NEW UID,II,TOT
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPDET",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S TYPE=$G(TYPE),STUB=$G(STUB),AID=$G(AID),XUSER=$G(XUSER)
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPDET D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define Header
S @DATA@(II)="I00100EVENTS_FIRED"_$C(30)
;
;Verify type
I TYPE="" S II=II+1,@DATA@(II)="0"_$C(30) G XEV
;
;Check if Excluding Current User
I XUSER D
. NEW SUB,Z,DZ
. D GETSUBSC^CIANBEVT(.SUB,TYPE)
. F Z=0:0 S Z=$O(@SUB@(Z)) Q:'Z D
.. S DZ=$P($G(@SUB@(Z)),U,4)
.. K @SUB@(Z)
.. I DZ=DUZ Q
.. S:DZ]"" LST("DUZ",DZ)=""
;
;Return Events Fired
S TOT=$$BRDCAST^CIANBEVT(TYPE,STUB,.LST,AID)
S II=II+1,@DATA@(II)=TOT_$C(30)
;
XEV S II=II+1,@DATA@(II)=$C(31)
Q
;
AUTHORCK(DATA,PIPIEN,VIEN) ;EP - BJPN CHECK VISIT NOTE AUTHOR
;
;This RPC returns whether the given user is the author of all notes
;for a problem for a visit
;
;Input:
; PIPIEN - Pointer to Prenatal Problem file entry
; VIEN - The visit IEN
;
;Output:
; 1 - User is the author of all the specific problem notes for a visit
; 0 - User is not the author of all the notes for a problem for a visit
;
S PIPIEN=$G(PIPIEN,""),VIEN=$G(VIEN,"")
I PIPIEN="" S BMXSEC="INVALID PIP VALUE" Q
I VIEN="" S BMXSEC="INVALID VIEN" Q
;
NEW UID,II,DFN,CNT,RESULT
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPDET",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
;S TMP=$NA(^TMP("BJPNPDET",UID))
;K @TMP
;
S II=0,RESULT=1
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPDET D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Header
S @DATA@(II)="T00001NOTE_AUTHOR"_$C(30)
;
;Retrieve DFN
S DFN=$$GET1^DIQ(90680.01,PIPIEN_",",.02,"I") I DFN="" S BMXSEC="INVALID PIPIEN/DFN" Q
;
D NOTES^BJPNPRL("",DFN,PIPIEN,1)
;
;Loop through and check each note for visit
S CNT=0 F S CNT=$O(^TMP("BJPNPRL",$J,CNT)) Q:CNT="" D
. NEW NODE,NVIEN,USER
. S NODE=^TMP("BJPNPRL",$J,CNT)
. S NVIEN=$P(NODE,U,4) I VIEN'=NVIEN Q
. S USER=$TR($P(NODE,U,10),$C(30)) I USER=DUZ Q
. S RESULT=0
S II=II+1,@DATA@(II)=RESULT_$C(30)
;
;Cleanup
K ^TMP("BJPNPRL",$J)
;
S II=II+1,@DATA@(II)=$C(31)
Q
;
DVNOTES(DATA,PIPIEN,VIEN,DCODE,DRSN) ;EP - BJPN DEL PRB VST NOTES
;
;This RPC deletes all notes entered for a particular visit for
;a specific prenatal problem
;
;Input:
; PIPIEN - Pointer to Prenatal Problem file entry
; VIEN - The visit IEN
; DCODE - Delete Code
; DRSN - Delete Reason
;
;Output:
; 1 - Notes deleted successfully
; 0 - Note deletion failed
;
S PIPIEN=$G(PIPIEN,""),VIEN=$G(VIEN,"")
I PIPIEN="" S BMXSEC="INVALID PIP VALUE" Q
I VIEN="" S BMXSEC="INVALID VIEN" Q
S DCODE=$G(DCODE,"")
S DRSN=$G(DRSN,"")
;
NEW UID,II,DFN,CNT,RESULT,NOTES
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPDET",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
;S TMP=$NA(^TMP("BJPNPDET",UID))
;K @TMP
;
S II=0,RESULT=1
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPDET D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Header
S @DATA@(II)="T00001SUCCESS"_$C(30)
;
;Retrieve DFN
S DFN=$$GET1^DIQ(90680.01,PIPIEN_",",.02,"I") I DFN="" S BMXSEC="INVALID PIPIEN/DFN" Q
;
D NOTES^BJPNPRL("",DFN,PIPIEN,1)
;
;Move to local (delete call wipes out results)
M NOTES=^TMP("BJPNPRL",$J)
;
;Loop through and delete each note for visit
S CNT=0 F S CNT=$O(NOTES(CNT)) Q:CNT="" D
. NEW NODE,NVIEN,VFIEN,VNIEN
. S NODE=NOTES(CNT)
. S NVIEN=$P(NODE,U,4) I VIEN'=NVIEN Q
. S VFIEN=$P(NODE,U,2)
. S VNIEN=$P(NODE,U,3)
. ;
. ;Delete each note
. D DEL^BJPNPUP(DATA,VIEN,VFIEN,VNIEN,DCODE,DRSN) ;BJPN DELETE PRB NOTE
;
S II=II+1,@DATA@(II)=RESULT_$C(30)
;
;Cleanup
K ^TMP("BJPNPRL",$J)
;
S II=II+1,@DATA@(II)=$C(31)
Q
;
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
BJPNPDET ;GDIT/HS/BEE-Prenatal Care Module Utility 2 Calls ; 08 May 2012 12:00 PM
+1 ;;2.0;PRENATAL CARE MODULE;;Feb 24, 2015;Build 63
+2 ;
+3 QUIT
+4 ;
DET(DATA,PIP) ;EP - BJPN PROBLEM DETAIL
+1 ;
+2 ;This RPC returns the problem detail for a Problem entry (including paste deletes)
+3 ;
+4 ;Input:
+5 ; PIP - Pointer to Prenatal Problem file entry
+6 ;
+7 NEW UID,II,TMP,REC,PLIEN,DFN,TERM,PIPIEN
+8 ;
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+10 SET DATA=$NAME(^TMP("BJPNPDET",UID))
+11 KILL @DATA
+12 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+13 ;
+14 SET TMP=$NAME(^TMP("BJPNPDT1",UID))
+15 KILL @TMP
+16 ;
+17 SET II=0
SET REC=0
+18 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPDET D UNWIND^%ZTER"
+19 ;
+20 ;Define Header
+21 SET @DATA@(II)="T01024REPORT_TEXT"_$CHAR(30)
+22 ;
+23 SET II=II+1
SET @DATA@(II)="This will eventually be filled with detail history"_$CHAR(30)
+24 GOTO XDET
+25 IF $GET(PIP)=""
GOTO XDET
+26 ;
+27 ;Retrieve Problem Pointer
+28 SET PLIEN=$$GET1^DIQ(90680.01,PIP_",",.03,"I")
IF PLIEN=""
GOTO XDET
+29 ;
+30 ;Retrieve DFN
+31 SET DFN=$$GET1^DIQ(90680.01,PIP_",",.02,"I")
IF DFN=""
GOTO XDET
+32 ;
+33 SET TERM=$$GET1^DIQ(90680.02,PLIEN_",",.02,"E")
+34 ;
+35 ;Loop through all instances of problem (including deletes)
+36 SET PIPIEN=""
FOR
SET PIPIEN=$ORDER(^BJPNPL("AC",DFN,PLIEN,PIPIEN))
IF 'PIPIEN
QUIT
Begin DoDot:1
+37 ;
+38 NEW VDT
+39 ;Step through all V OB entries for PIPIEN
+40 SET REC=0
SET VDT=""
FOR
SET VDT=$ORDER(^AUPNVOB("AE",DFN,PIPIEN,VDT))
IF VDT=""
QUIT
Begin DoDot:2
+41 ;
+42 NEW VFIEN
+43 SET VFIEN=""
FOR
SET VFIEN=$ORDER(^AUPNVOB("AE",DFN,PIPIEN,VDT,VFIEN))
IF VFIEN=""
QUIT
Begin DoDot:3
+44 ;
+45 NEW ALMDT,LMDT,LMBY,OEDT,OEBY,AIEN
+46 ;
+47 ;Pull LMDT
+48 SET ALMDT=$$GET1^DIQ(9000010.43,VFIEN_",",1218,"I")
+49 IF ALMDT=""
SET ALMDT=$$GET1^DIQ(9000010.43,VFIEN_",",1216,"I")
+50 ;
+51 ;Loop through audit history
+52 SET AIEN=0
FOR
SET AIEN=$ORDER(^AUPNVOB(VFIEN,22,AIEN))
IF 'AIEN
QUIT
Begin DoDot:4
+53 ;
+54 NEW DA,IENS,RCNT,DA,IENS,ATYP,AVAL,VALUE,RCNT,VIEN
+55 ;
+56 SET DA(1)=VFIEN
SET DA=AIEN
SET IENS=$$IENS^DILF(.DA)
+57 SET ATYP=$$GET1^DIQ(9000010.4311,IENS,".01","I")
+58 SET AVAL=$$GET1^DIQ(9000010.4311,IENS,".02","I")
+59 ;
+60 ;Define Line
+61 SET VALUE=$$VALUE(VFIEN,ATYP,AVAL)
+62 ;
+63 ;Date/User Handling
+64 IF AVAL=1216
SET OEDT=VALUE
QUIT
+65 IF AVAL=1217
SET OEBY=VALUE
QUIT
+66 IF AVAL=1218
SET LMDT=VALUE
QUIT
+67 IF AVAL=1219
SET LMBY=VALUE
QUIT
+68 ;
+69 ;Log entry
+70 FOR RCNT=1:1:$LENGTH(VALUE,$CHAR(28))
SET REC=REC+1
SET @TMP@(ALMDT,REC)=$PIECE(VALUE,$CHAR(28),RCNT)
End DoDot:4
+71 ;
+72 ;Log Date/User
+73 IF $GET(LMDT)]""
SET REC=REC+1
SET @TMP@(ALMDT,REC)=LMDT
+74 IF $GET(LMBY)]""
SET REC=REC+1
SET @TMP@(ALMDT,REC)=LMBY
+75 IF $GET(OEDT)]""
SET REC=REC+1
SET @TMP@(ALMDT,REC)=OEDT
+76 IF $GET(OEBY)]""
SET REC=REC+1
SET @TMP@(ALMDT,REC)=OEBY
+77 ;
+78 ;Visit Date
+79 SET VIEN=$$GET1^DIQ(9000010.43,VFIEN,.03,"I")
+80 SET REC=REC+1
SET @TMP@(ALMDT,REC)=" *Visit Date: "_$$FMTE^BJPNPRL($$GET1^DIQ(9000010,VIEN_",",.01,"I"))
+81 ;
+82 ;Insert blank line
+83 SET REC=REC+1
SET @TMP@(ALMDT,REC)=""
End DoDot:3
End DoDot:2
End DoDot:1
+84 ;
+85 ;Assemble Header
+86 SET II=II+1
SET @DATA@(II)="SNOMED Term: "_TERM_$CHAR(13)_$CHAR(10)
+87 SET II=II+1
SET @DATA@(II)=$CHAR(13)_$CHAR(10)
+88 ;
+89 ;Current Info
+90 SET II=II+1
SET @DATA@(II)="CURRENT INFORMATION"_$CHAR(13)_$CHAR(10)
+91 SET II=II+1
SET @DATA@(II)=$CHAR(13)_$CHAR(10)
+92 SET II=II+1
SET @DATA@(II)=" *Provider Text: "_$$GET1^DIQ(90680.01,PIP_",",.05,"E")_$CHAR(13)_$CHAR(10)
+93 SET II=II+1
SET @DATA@(II)=" *Priority: "_$$GET1^DIQ(90680.01,PIP_",",.06,"E")_$CHAR(13)_$CHAR(10)
+94 SET II=II+1
SET @DATA@(II)=" *Scope: "_$$GET1^DIQ(90680.01,PIP_",",.07,"E")_$CHAR(13)_$CHAR(10)
+95 SET II=II+1
SET @DATA@(II)=" *Status: "_$$GET1^DIQ(90680.01,PIP_",",.08,"E")_$CHAR(13)_$CHAR(10)
+96 SET II=II+1
SET @DATA@(II)=" *Definitive EDD: "_$$FMTE^BJPNPRL($$GET1^DIQ(90680.01,PIP_",",.09,"I"))_$CHAR(13)_$CHAR(10)
+97 SET II=II+1
SET @DATA@(II)=" *Current Note: "_$$GET1^DIQ(90680.01,PIP_",",3,"E")_$CHAR(13)_$CHAR(10)
+98 SET II=II+1
SET @DATA@(II)=$CHAR(13)_$CHAR(10)
+99 SET II=II+1
SET @DATA@(II)="PROBLEM HISTORY"_$CHAR(13)_$CHAR(10)
+100 SET II=II+1
SET @DATA@(II)=$CHAR(13)_$CHAR(10)
+101 ;
+102 ;Loop through results and format
+103 NEW VDT
+104 SET VDT=""
FOR
SET VDT=$ORDER(@TMP@(VDT),-1)
IF VDT=""
QUIT
Begin DoDot:1
+105 NEW REC
+106 SET REC=""
FOR
SET REC=$ORDER(@TMP@(VDT,REC))
IF REC=""
QUIT
Begin DoDot:2
+107 SET II=II+1
SET @DATA@(II)=@TMP@(VDT,REC)_$CHAR(13)_$CHAR(10)
End DoDot:2
End DoDot:1
+108 SET II=II+1
SET @DATA@(II)=$CHAR(30)
+109 ;
XDET KILL @TMP
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
VALUE(VFIEN,ATYP,AVAL) ;EP - Retrieve field value
+1 ;
+2 IF $GET(VFIEN)=""
QUIT ""
+3 IF $GET(ATYP)=""
QUIT ""
+4 IF $GET(AVAL)=""
QUIT ""
+5 ;
+6 SET VALUE=""
+7 ;
+8 ;Audit Header
+9 IF ATYP="C"
QUIT AVAL
+10 ;
+11 ;SNOMED Term
+12 IF AVAL=".12"
Begin DoDot:1
+13 NEW PKIEN,TERM
+14 SET PKIEN=$$GET1^DIQ(9000010.43,VFIEN_",",.12,"I")
IF PKIEN=""
QUIT
+15 SET VALUE=" *Set SNOMED Term to: "_$$GET1^DIQ(90680.02,PKIEN_",",.02,"E")
End DoDot:1
QUIT VALUE
+16 ;
+17 ;Used as POV
+18 IF AVAL=".05"
Begin DoDot:1
+19 NEW POV
+20 SET POV=$$GET1^DIQ(9000010.43,VFIEN_",",.05,"E")
+21 SET VALUE=" *Set As POV set to: "_$SELECT(POV]"":POV,1:"No")
End DoDot:1
QUIT VALUE
+22 ;
+23 ;Priority
+24 IF AVAL=".06"
Begin DoDot:1
+25 NEW PRI
+26 SET PRI=$$GET1^DIQ(9000010.43,VFIEN_",",.06,"E")
+27 SET VALUE=" *Priority set to: "_$SELECT(PRI]"":PRI,1:"<Not Set>")
End DoDot:1
QUIT VALUE
+28 ;
+29 ;Provider Text
+30 IF AVAL=".07"
Begin DoDot:1
+31 NEW PTX
+32 SET PTX=$$GET1^DIQ(9000010.43,VFIEN_",",.07,"E")
+33 SET VALUE=" *Provider Text set to: "_$SELECT(PTX]"":PTX,1:"<Not Set>")
End DoDot:1
QUIT VALUE
+34 ;
+35 ;Scope
+36 IF AVAL=".08"
Begin DoDot:1
+37 NEW SCO
+38 SET SCO=$$GET1^DIQ(9000010.43,VFIEN_",",.08,"E")
+39 SET VALUE=" *Scope set to: "_$SELECT(SCO]"":SCO,1:"<Not Set>")
End DoDot:1
QUIT VALUE
+40 ;
+41 ;Status
+42 IF AVAL=".09"
Begin DoDot:1
+43 NEW STS
+44 SET STS=$$GET1^DIQ(9000010.43,VFIEN_",",.09,"E")
+45 SET VALUE=" *Status set to: "_$SELECT(STS]"":STS,1:"<Not Set>")
End DoDot:1
QUIT VALUE
+46 ;
+47 ;DEDD
+48 IF AVAL=".1"
Begin DoDot:1
+49 NEW DEDD
+50 SET DEDD=$$GET1^DIQ(9000010.43,VFIEN_",",.1,"E")
+51 SET VALUE=" *Definitive EDD set to: "_$SELECT(DEDD]"":DEDD,1:"<Not Set>")
End DoDot:1
QUIT VALUE
+52 ;
+53 ;Provider Narrative
+54 IF AVAL=".11"
Begin DoDot:1
+55 NEW PNAR
+56 SET PNAR=$$GET1^DIQ(9000010.43,VFIEN_",",.11,"E")
+57 SET VALUE=" *Provider Narrative set to: "_$SELECT(PNAR]"":PNAR,1:"<Not Set>")
End DoDot:1
QUIT VALUE
+58 ;
+59 ;Original Entry Date
+60 IF AVAL="1216"
Begin DoDot:1
+61 NEW OEDT
+62 SET OEDT=$$GET1^DIQ(9000010.43,VFIEN_",",1216,"I")
+63 SET OEDT=$$FMTE^BJPNPRL(OEDT)
+64 SET VALUE=" *Original Entry Date: "_OEDT
End DoDot:1
QUIT VALUE
+65 ;
+66 ;Original Entered By
+67 IF AVAL="1217"
Begin DoDot:1
+68 NEW OEBY
+69 SET OEBY=$$GET1^DIQ(9000010.43,VFIEN_",",1217,"E")
+70 SET VALUE=" *Original Entered By: "_OEBY
End DoDot:1
QUIT VALUE
+71 ;
+72 ;Last Modified Dt
+73 IF AVAL="1218"
Begin DoDot:1
+74 NEW LMDT
+75 SET LMDT=$$GET1^DIQ(9000010.43,VFIEN_",",1218,"I")
+76 SET LMDT=$$FMTE^BJPNPRL(LMDT)
+77 SET VALUE=" *Entry Modified On: "_LMDT
End DoDot:1
QUIT VALUE
+78 ;
+79 ;Last Modified By
+80 IF AVAL="1219"
Begin DoDot:1
+81 NEW LMBY
+82 SET LMBY=$$GET1^DIQ(9000010.43,VFIEN_",",1219,"E")
+83 SET VALUE=" *Entry Modified By: "_LMBY
End DoDot:1
QUIT VALUE
+84 ;
+85 ;Problem Deleted By
+86 IF AVAL="2.01"
Begin DoDot:1
+87 NEW PDBY
+88 SET PDBY=$$GET1^DIQ(9000010.43,VFIEN_",",2.01,"E")
+89 SET VALUE=" *Problem Deleted By: "_$SELECT(PDBY]"":PDBY,1:"<Not Set>")
End DoDot:1
QUIT VALUE
+90 ;
+91 IF AVAL="2.02"
Begin DoDot:1
+92 NEW PDDT
+93 SET PDDT=$$GET1^DIQ(9000010.43,VFIEN_",",2.02,"I")
+94 SET PDDT=$$FMTE^BJPNPRL(PDDT)
+95 SET VALUE=" *Problem Deleted On: "_$SELECT(PDDT]"":PDDT,1:"<Not Set>")
End DoDot:1
QUIT VALUE
+96 ;
+97 ;Delete Code
+98 IF AVAL="2.03"
Begin DoDot:1
+99 NEW DCOD
+100 SET DCOD=$$GET1^DIQ(9000010.43,VFIEN_",",2.03,"E")
+101 SET VALUE=" *Problem Delete Reason: "_$SELECT(DCOD]"":DCOD,1:"<Not Set>")
End DoDot:1
QUIT VALUE
+102 ;
+103 ;Delete Reason
+104 IF AVAL="2.04"
Begin DoDot:1
+105 NEW DRSN
+106 SET DRSN=$$GET1^DIQ(9000010.43,VFIEN_",",2.04,"E")
+107 SET VALUE=" *Problem Delete Reason: "_$SELECT(DRSN]"":DRSN,1:"<Not Set>")
End DoDot:1
QUIT VALUE
+108 ;
+109 ;Problem Note Additions
+110 IF $PIECE(AVAL,":")=2100
IF $PIECE(AVAL,":",4)'="D"
Begin DoDot:1
+111 NEW NOTE,DA,IENS
+112 SET DA(1)=VFIEN
SET DA=$PIECE(AVAL,":",2)
SET IENS=$$IENS^DILF(.DA)
+113 SET VALUE=$$GET1^DIQ(9000010.431,IENS,.01,"E")
+114 IF VALUE]""
SET VALUE=" *Note Added: "_VALUE
End DoDot:1
QUIT VALUE
+115 ;
+116 ;Problem Note Deletions
+117 IF $PIECE(AVAL,":")=2100
IF $PIECE(AVAL,":",4)="D"
Begin DoDot:1
+118 NEW NOTE,DA,IENS,VAL
+119 SET VALUE=""
+120 SET DA(1)=$PIECE(AVAL,":",2)
SET DA=$PIECE(AVAL,":",3)
SET IENS=$$IENS^DILF(.DA)
+121 SET VAL=$$GET1^DIQ(9000010.431,IENS,.01,"E")
+122 IF VAL]""
SET VALUE=" *Note Deleted: "_VAL
+123 ;
+124 ;Deleted On
+125 SET VAL=$$FMTE^BJPNPRL($$GET1^DIQ(9000010.431,IENS,2.02,"I"))
+126 IF VAL]""
SET VALUE=VALUE_$SELECT(VALUE]"":$CHAR(28),1:"")_" *Note Deleted On: "_VAL
+127 ;
+128 ;Deleted By
+129 SET VAL=$$GET1^DIQ(9000010.431,IENS,2.01,"E")
+130 IF VAL]""
SET VALUE=VALUE_$SELECT(VALUE]"":$CHAR(28),1:"")_" *Note Deleted By: "_VAL
+131 ;
+132 ;Delete Code
+133 SET VAL=$$GET1^DIQ(9000010.431,IENS,2.03,"E")
+134 IF VAL]""
SET VALUE=VALUE_$SELECT(VALUE]"":$CHAR(28),1:"")_" *Note Deletion Code: "_VAL
+135 ;
+136 ;Delete Reason
+137 SET VAL=$$GET1^DIQ(9000010.431,IENS,2.04,"E")
+138 IF VAL]""
SET VALUE=VALUE_$SELECT(VALUE]"":$CHAR(28),1:"")_" *Note Deletion Reason: "_VAL
End DoDot:1
QUIT VALUE
+139 ;
+140 QUIT AVAL
+141 ;
EDIT(DATA,DFN) ;EP - BJPN CAN EDIT PIP
+1 ;
+2 ;This RPC returns whether the PIP can be edited
+3 ;
+4 ;Input:
+5 ; DFN - Patient IEN
+6 ;
+7 NEW UID,II,KEY,RET,X1,X2,X
+8 ;
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+10 SET DATA=$NAME(^TMP("BJPNPDET",UID))
+11 KILL @DATA
+12 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+13 ;
+14 SET II=0
+15 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPDET D UNWIND^%ZTER"
+16 ;
+17 ;Define Header
+18 SET @DATA@(II)="T00001CAN_EDIT^T00100VIEW_ONLY_REASON"_$CHAR(30)
+19 ;
+20 ;Key Check
+21 SET KEY=0
Begin DoDot:1
+22 IF $$HASKEY^CIAVCXUS("ORES",DUZ)
SET KEY=1
QUIT
+23 IF $$HASKEY^CIAVCXUS("PROVIDER",DUZ)
SET KEY=1
QUIT
+24 IF $$HASKEY^CIAVCXUS("ORELSE",DUZ)
SET KEY=1
QUIT
+25 IF $$HASKEY^CIAVCXUS("BGOZ PROBLEM LIST EDIT",DUZ)
SET KEY=1
QUIT
+26 IF $$HASKEY^CIAVCXUS("BGOZ VIEW ONLY",DUZ)
SET KEY=1
End DoDot:1
+27 IF KEY=0
SET II=II+1
SET @DATA@(II)="1^USER DOES NOT HOLD THE APPROPRIATE KEY(S) TO VIEW/EDIT"_$CHAR(30)
GOTO XEDIT
+28 ;
+29 ;Parameter check
+30 IF $$HASKEY^CIAVCXUS("@BJPN DISABLE PRENATAL EDITING",DUZ)
Begin DoDot:1
+31 SET II=II+1
SET @DATA@(II)="3^USER OR USER CLASS FOUND IN BJPN DISABLE PRENATAL EDITING"_$CHAR(30)
End DoDot:1
GOTO XEDIT
+32 ;
+33 ;BGOZ VIEW ONLY key check
+34 IF $$HASKEY^CIAVCXUS("BGOZ VIEW ONLY",DUZ)
SET II=II+1
SET @DATA@(II)="2^USER HOLDS THE BGOZ VIEW ONLY KEY"_$CHAR(30)
GOTO XEDIT
+35 ;
+36 ;Definitive EDD checks
+37 ;
+38 SET DEDD=$$DEDD(DFN)
+39 IF DEDD=""
SET DEDD=$$GET1^DIQ(9000017,DFN_",",1311,"I")
+40 IF DEDD=""
Begin DoDot:1
+41 SET II=II+1
SET @DATA@(II)="4^NO CURRENT OR PAST DEFINITIVE EDD FOUND"_$CHAR(30)
End DoDot:1
GOTO XEDIT
+42 ;
+43 ;Definitive EDD date range check
+44 DO GETPAR^CIAVMRPC(.RET,"BJPN POST DEDD DAYS","SYS",1,"I","")
+45 ;
+46 ;If blank default to 70
+47 IF +RET<1
SET RET=70
+48 ;
+49 ;Check range
+50 SET X1=DEDD
SET X2=-280
DO C^%DTC
+51 IF DEDD>0
IF DT<X
SET II=II+1
SET @DATA@(II)="5^TODAYS DATE IS EARLIER THAN ALLOWABLE EDIT RANGE"_$CHAR(30)
GOTO XEDIT
+52 SET X1=DEDD
SET X2=RET
DO C^%DTC
+53 IF DEDD>0
IF DT>X
SET II=II+1
SET @DATA@(II)="6^TODAYS DATE IS GREATER THAN ALLOWABLE POST RANGE"_$CHAR(30)
GOTO XEDIT
+54 ;
+55 SET II=II+1
SET @DATA@(II)="0^"_$CHAR(30)
+56 ;
XEDIT SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
DEDD(DFN) ;EP - Return Last Definitive EDD
+1 ;
+2 NEW PIPIEN,DEDD
+3 ;
+4 IF $GET(DFN)=""
QUIT ""
+5 ;
+6 ;Loop through problems and find last DEDD
+7 SET (DEDD,PIPIEN)=""
FOR
SET PIPIEN=$ORDER(^BJPNPL("D",DFN,PIPIEN))
IF 'PIPIEN
QUIT
Begin DoDot:1
+8 ;
+9 ;Skip deletes
+10 IF $$GET1^DIQ(90680.01,PIPIEN_",",2.01,"I")]""
QUIT
+11 ;
+12 ;Pull DEDD
+13 SET DEDD=$$GET1^DIQ(90680.01,PIPIEN_",",.09,"I")
End DoDot:1
IF DEDD
QUIT
+14 QUIT DEDD
+15 ;
FIREEV(DATA,TYPE,STUB,LST,AID,XUSER) ;EP - BJPN FIRE EHR EVENT
+1 ;
+2 ;This RPC will fire the passed event in EHR
+3 ;
+4 ;Input:
+5 ; TYPE - Event Type to Broadcast (ex. PCC.<dfn>.PIP)
+6 ; STUB - Event Stub (optional)
+7 ; LST - Recipient List (optional)
+8 ; AID - Application ID (optional)
+9 ; XUSER - If 1, do not include user in event fire
+10 ;
+11 NEW UID,II,TOT
+12 ;
+13 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+14 SET DATA=$NAME(^TMP("BJPNPDET",UID))
+15 KILL @DATA
+16 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+17 ;
+18 SET TYPE=$GET(TYPE)
SET STUB=$GET(STUB)
SET AID=$GET(AID)
SET XUSER=$GET(XUSER)
+19 ;
+20 SET II=0
+21 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPDET D UNWIND^%ZTER"
+22 ;
+23 ;Define Header
+24 SET @DATA@(II)="I00100EVENTS_FIRED"_$CHAR(30)
+25 ;
+26 ;Verify type
+27 IF TYPE=""
SET II=II+1
SET @DATA@(II)="0"_$CHAR(30)
GOTO XEV
+28 ;
+29 ;Check if Excluding Current User
+30 IF XUSER
Begin DoDot:1
+31 NEW SUB,Z,DZ
+32 DO GETSUBSC^CIANBEVT(.SUB,TYPE)
+33 FOR Z=0:0
SET Z=$ORDER(@SUB@(Z))
IF 'Z
QUIT
Begin DoDot:2
+34 SET DZ=$PIECE($GET(@SUB@(Z)),U,4)
+35 KILL @SUB@(Z)
+36 IF DZ=DUZ
QUIT
+37 IF DZ]""
SET LST("DUZ",DZ)=""
End DoDot:2
End DoDot:1
+38 ;
+39 ;Return Events Fired
+40 SET TOT=$$BRDCAST^CIANBEVT(TYPE,STUB,.LST,AID)
+41 SET II=II+1
SET @DATA@(II)=TOT_$CHAR(30)
+42 ;
XEV SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
AUTHORCK(DATA,PIPIEN,VIEN) ;EP - BJPN CHECK VISIT NOTE AUTHOR
+1 ;
+2 ;This RPC returns whether the given user is the author of all notes
+3 ;for a problem for a visit
+4 ;
+5 ;Input:
+6 ; PIPIEN - Pointer to Prenatal Problem file entry
+7 ; VIEN - The visit IEN
+8 ;
+9 ;Output:
+10 ; 1 - User is the author of all the specific problem notes for a visit
+11 ; 0 - User is not the author of all the notes for a problem for a visit
+12 ;
+13 SET PIPIEN=$GET(PIPIEN,"")
SET VIEN=$GET(VIEN,"")
+14 IF PIPIEN=""
SET BMXSEC="INVALID PIP VALUE"
QUIT
+15 IF VIEN=""
SET BMXSEC="INVALID VIEN"
QUIT
+16 ;
+17 NEW UID,II,DFN,CNT,RESULT
+18 ;
+19 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+20 SET DATA=$NAME(^TMP("BJPNPDET",UID))
+21 KILL @DATA
+22 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+23 ;
+24 ;S TMP=$NA(^TMP("BJPNPDET",UID))
+25 ;K @TMP
+26 ;
+27 SET II=0
SET RESULT=1
+28 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPDET D UNWIND^%ZTER"
+29 ;
+30 ;Header
+31 SET @DATA@(II)="T00001NOTE_AUTHOR"_$CHAR(30)
+32 ;
+33 ;Retrieve DFN
+34 SET DFN=$$GET1^DIQ(90680.01,PIPIEN_",",.02,"I")
IF DFN=""
SET BMXSEC="INVALID PIPIEN/DFN"
QUIT
+35 ;
+36 DO NOTES^BJPNPRL("",DFN,PIPIEN,1)
+37 ;
+38 ;Loop through and check each note for visit
+39 SET CNT=0
FOR
SET CNT=$ORDER(^TMP("BJPNPRL",$JOB,CNT))
IF CNT=""
QUIT
Begin DoDot:1
+40 NEW NODE,NVIEN,USER
+41 SET NODE=^TMP("BJPNPRL",$JOB,CNT)
+42 SET NVIEN=$PIECE(NODE,U,4)
IF VIEN'=NVIEN
QUIT
+43 SET USER=$TRANSLATE($PIECE(NODE,U,10),$CHAR(30))
IF USER=DUZ
QUIT
+44 SET RESULT=0
End DoDot:1
+45 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+46 ;
+47 ;Cleanup
+48 KILL ^TMP("BJPNPRL",$JOB)
+49 ;
+50 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+51 QUIT
+52 ;
DVNOTES(DATA,PIPIEN,VIEN,DCODE,DRSN) ;EP - BJPN DEL PRB VST NOTES
+1 ;
+2 ;This RPC deletes all notes entered for a particular visit for
+3 ;a specific prenatal problem
+4 ;
+5 ;Input:
+6 ; PIPIEN - Pointer to Prenatal Problem file entry
+7 ; VIEN - The visit IEN
+8 ; DCODE - Delete Code
+9 ; DRSN - Delete Reason
+10 ;
+11 ;Output:
+12 ; 1 - Notes deleted successfully
+13 ; 0 - Note deletion failed
+14 ;
+15 SET PIPIEN=$GET(PIPIEN,"")
SET VIEN=$GET(VIEN,"")
+16 IF PIPIEN=""
SET BMXSEC="INVALID PIP VALUE"
QUIT
+17 IF VIEN=""
SET BMXSEC="INVALID VIEN"
QUIT
+18 SET DCODE=$GET(DCODE,"")
+19 SET DRSN=$GET(DRSN,"")
+20 ;
+21 NEW UID,II,DFN,CNT,RESULT,NOTES
+22 ;
+23 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+24 SET DATA=$NAME(^TMP("BJPNPDET",UID))
+25 KILL @DATA
+26 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+27 ;
+28 ;S TMP=$NA(^TMP("BJPNPDET",UID))
+29 ;K @TMP
+30 ;
+31 SET II=0
SET RESULT=1
+32 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPDET D UNWIND^%ZTER"
+33 ;
+34 ;Header
+35 SET @DATA@(II)="T00001SUCCESS"_$CHAR(30)
+36 ;
+37 ;Retrieve DFN
+38 SET DFN=$$GET1^DIQ(90680.01,PIPIEN_",",.02,"I")
IF DFN=""
SET BMXSEC="INVALID PIPIEN/DFN"
QUIT
+39 ;
+40 DO NOTES^BJPNPRL("",DFN,PIPIEN,1)
+41 ;
+42 ;Move to local (delete call wipes out results)
+43 MERGE NOTES=^TMP("BJPNPRL",$JOB)
+44 ;
+45 ;Loop through and delete each note for visit
+46 SET CNT=0
FOR
SET CNT=$ORDER(NOTES(CNT))
IF CNT=""
QUIT
Begin DoDot:1
+47 NEW NODE,NVIEN,VFIEN,VNIEN
+48 SET NODE=NOTES(CNT)
+49 SET NVIEN=$PIECE(NODE,U,4)
IF VIEN'=NVIEN
QUIT
+50 SET VFIEN=$PIECE(NODE,U,2)
+51 SET VNIEN=$PIECE(NODE,U,3)
+52 ;
+53 ;Delete each note
+54 ;BJPN DELETE PRB NOTE
DO DEL^BJPNPUP(DATA,VIEN,VFIEN,VNIEN,DCODE,DRSN)
End DoDot:1
+55 ;
+56 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+57 ;
+58 ;Cleanup
+59 KILL ^TMP("BJPNPRL",$JOB)
+60 ;
+61 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+62 QUIT
+63 ;
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
