BJPNGNOT ;GDIT/HS/BEE-Prenatal Care Module Get Note Detail for PIP ; 08 May 2012 12:00 PM
;;2.0;PRENATAL CARE MODULE;**4,8**;Feb 24, 2015;Build 25
;
Q
;
NOTES(DATA,DFN,PR,API,TYPE,NOCMP,VIEN) ;EP - BJPN GET PROB NOTES
;
;Get BJPN CARE PLANS, GOALS, VISIT INSTRUCTIONS
;
;This RPC returns notes entered for problems on the PIP
;
;Input: DFN - Patient IEN
; PR - Problem IEN(s)
; API - 1 if called from an API (Optional)
; TYPE - (C) Care Plans, (G) Goals, (I) Visit Instructions,
; (O) OB Notes, (T) Treatment Plan/Education, null for All
; NOCMP - (1) Do not recompile data (called by PIP call)
; VIEN - If passed in, limit visit instructions returned to that visit
;
S DFN=$G(DFN),PR=$G(PR),API=$G(API),TYPE=$G(TYPE),NOCMP=$G(NOCMP)
I TYPE'="",TYPE'="C",TYPE'="G",TYPE'="I",TYPE'="T",TYPE'="O" S BMXSEC="Invalid TYPE value" Q
;
NEW UID,II,PIPIEN,SORT,PC,PARY,NEDT,TMP,SIGN,LTYPE,C8,C9
S UID=$S(API=1:$J,$G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNGNOT",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
S VIEN=$G(VIEN)
;
;Define delimiters
S C8=$C(28),C9=$C(29)
;
;Assemble TYPE list
S LTYPE=$S(TYPE="":"GCIOT",1:TYPE) S:LTYPE["T" LTYPE=LTYPE_"E"
;
;Assemble Problem List Array
I $G(PR)]"" F II=1:1:$L(PR,$C(28)) S PC=$P(PR,$C(28),II) I PC]"" S PARY(PC)=""
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPRL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define Header
S @DATA@(II)="I00010PIPIEN^I00010PRBIEN^T00001PREGNANT^T04096NOTES"_$C(30)
;
;Verify DFN
I DFN="" G XNOTES
;
;Definitive EDD date range check
D GETPAR^CIAVMRPC(.NEDT,"BJPN POST DEDD DAYS","SYS",1,"I","")
;
;If blank default to 70
I +$G(NEDT)<1 S NEDT=70
;
;Call EHR API and format results into usable data - skip if flag and already compiled
S TMP=$NA(^TMP("BJPNIPL",UID)) ;Define compiled data reference
I '$G(NOCMP)!($O(@TMP@(""))="") D COMP^BJPNUTIL(DFN,UID)
;
;Array(n)=Type (G OR C) [1] ^ C Plan IEN [2] ^ Prob IEN [4] ^ Who entered [4] ^ Date Entered [5] ^ Status [6] ^ SIGN FLAG [7]
; =~t [1] ^ Text of the item [2]
;Array(n)="I" [1] ^ Instr IEN[2] ^ Prob IEN [3] ^ Vst Date [4] ^ Facility [5] ^ Prv IEN [6] ^ Location [7] ^ Entered Dt [8] ^ Visit IEN [9] ^V cat [10] ^ Locked [11] ^ Prov Name [12] ^ signed [13]
; =~t [1] ^Text of the item [2]
;Array(n)="O" [1] ^ Instr IEN[2] ^ Prob IEN [3] ^ Vst Date [4] ^ Facility [5] ^ Prv IEN [6] ^ Location [7] ^ Entered Dt [8] ^ Visit IEN [9] ^V cat [10] ^ Locked [11] ^ Prov Name [12] ^ signed [13]
; =~t [1] ^Text of the item [2]
;Array(n)="T" [1] ^ TR IEN[2] ^ SNOMED term [3] ^ Prob IEN [4] ^ Vst Date [5] ^ Facility [6] ^ Prv IEN [7] ^ Location [8] ^ Entered Dt [9] ^ Visit IEN [10] ^ V Cat [11] ^Locked [12] ^ Prov name [13]
;Array(n)="E" [1] ^ Topic [2] ^ Date [3]
;
;Loop through problem list and pull goals and care plans
S PIPIEN="" F S PIPIEN=$O(^BJPNPL("D",DFN,PIPIEN)) Q:PIPIEN="" D
. ;
. ;Only include selected problems
. I $D(PARY),'$D(PARY(PIPIEN)) Q
. ;
. NEW CNT,MDT,BGO,PRBIEN,ITYPE,TYPE,NOTES,DEL
. ;
. ;Get IPL pointer
. S PRBIEN=$$GET1^DIQ(90680.01,PIPIEN_",",".1","I") Q:PRBIEN=""
. ;
. ;Skip deletes
. S DEL=$$GET1^DIQ(90680.01,PIPIEN_",",2.01,"I") Q:DEL]"" ;PIP Delete
. S DEL=$$GET1^DIQ(9000011,PRBIEN_",",2.02,"I") I DEL]"" D Q ;IPL Delete
.. ;
.. ;If deleted on IPL, need to delete in PIP
.. NEW BJPNUPD,ERROR
.. S BJPNUPD(90680.01,PIPIEN_",",2.01)=$$GET1^DIQ(9000011,PRBIEN_",",2.01,"I") ;Deleted By
.. S BJPNUPD(90680.01,PIPIEN_",",2.02)=$$GET1^DIQ(9000011,PRBIEN_",",2.02,"I") ;Del Dt/Tm
.. S BJPNUPD(90680.01,PIPIEN_",",2.03)=$$GET1^DIQ(9000011,PRBIEN_",",2.03,"I") ;Del Rsn
.. S BJPNUPD(90680.01,PIPIEN_",",2.04)=$$GET1^DIQ(9000011,PRBIEN_",",2.04,"I") ;Del Other
.. D FILE^DIE("","BJPNUPD","ERROR")
. ;
. ;Reset Array variable
. S NOTES=""
. ;
. ;Loop through by each TYPE
. F ITYPE=1:1:$L(LTYPE) S TYPE=$E(LTYPE,ITYPE) D
.. ;Loop through compiled results for type
.. S BGO="" F S BGO=$O(@TMP@(TYPE,PRBIEN,BGO),-1) Q:BGO="" D
... ;
... NEW APIRES,VISIT,DEDD,BRNG,ERNG,NIEN,X1,X2,X,VDT
... NEW DTTM,MDBY,ILMBY,NOTE,NSTS,SIGN,ACT
... ;
... S SIGN=""
... S APIRES=$G(@TMP@(TYPE,PRBIEN,BGO,0)) Q:APIRES=""
... ;
... ;Pull Visit - If V VISIT INSTRUCTIONS/V OB (GOALS and CARE PLANS are not visit driven)
... S (VISIT,VDT)=""
... I (TYPE="I")!(TYPE="O") S VISIT=$P(APIRES,U,9),VDT=$P(APIRES,U,4)
... S:TYPE="T" VISIT=$P(APIRES,U,10),VDT=$P(APIRES,U,5)
... I TYPE="E" D
.... NEW VEDIEN
.... S VEDIEN=$P(APIRES,U,6) Q:VEDIEN=""
.... S VISIT=$$GET1^DIQ(9000010.16,VEDIEN_",",.03,"I")
.... S VDT=$$GET1^DIQ(9000010,VISIT,.01,"I")
... ;
... ;Filter on visit
... ;BJPN*2.0*4;Do not filter on visit
... ;I ((TYPE="I")!(TYPE="T")!(TYPE="E")),VIEN]"",VIEN'=VISIT Q
... ;
... ;Note IEN (Pointer to entry)
... I TYPE'="E" S NIEN=$P(APIRES,U,2)
... E S NIEN=$P(APIRES,U,6)
... Q:NIEN=""
... ;
... ;Pull Definitive EDD
... S DEDD=$$GET1^DIQ(90680.01,PIPIEN_",",.09,"I")
... S X1=DEDD,X2=-280 D C^%DTC S BRNG=X
... S X1=DEDD,X2=NEDT D C^%DTC S ERNG=X
... ;
... ;Get note date/time entered and by - V VISIT INSTRUCTIONS
... S (DTTM,ILMBY)=""
... I TYPE="I" D
.... S DTTM=$$GET1^DIQ(9000010.58,NIEN_",",1216,"I")
.... S ILMBY=$$GET1^DIQ(9000010.58,NIEN_",",1217,"I")
.... S SIGN=$P(APIRES,U,13)
... ;
... ;Get note date/time entered and by - V OB
... I TYPE="O" D
.... S DTTM=$$GET1^DIQ(9000010.43,NIEN_",",1216,"I")
.... S ILMBY=$$GET1^DIQ(9000010.43,NIEN_",",1217,"I")
.... S SIGN=$P(APIRES,U,13)
... ;
... ;Get note date/time entered and by - CARE PLAN
... I TYPE'="I",TYPE'="O",TYPE'="T",TYPE'="E" D
.... NEW IENS,DA
.... S DA=$O(^AUPNCPL(NIEN,11,"B","A",""),-1) Q:DA=""
.... S DA(1)=NIEN,IENS=$$IENS^DILF(.DA)
.... S DTTM=$$GET1^DIQ(9000092.11,IENS,".03","I")
.... S ILMBY=$$GET1^DIQ(9000092.11,IENS,".02","I")
.... S SIGN=$P(APIRES,U,7)
... ;
... ;Get treatment plan date/time and by - V TREATMENT/REGIMEN
... I TYPE="T" D
.... S DTTM=$$GET1^DIQ(9000010.61,NIEN_",",1216,"I")
.... S ILMBY=$$GET1^DIQ(9000010.61,NIEN_",",1217,"I")
... ;
... ;Get education plan date/time and by - V PATIENT ED
... I TYPE="E" D
.... S DTTM=$$GET1^DIQ(9000010.16,NIEN_",",1216,"I")
.... S ILMBY=$$GET1^DIQ(9000010.16,NIEN_",",1217,"I")
... ;
... Q:DTTM=""
... S MDBY=$$GET1^DIQ(200,ILMBY_",",".01","E")
... ;
... ;Get Note
... I TYPE="T" S NOTE=$P($G(@TMP@(TYPE,PRBIEN,BGO,0)),U,14)
... E I TYPE="E" S NOTE=$P(APIRES,U,2)
... E D
.... S NOTE=""
.... NEW NIEN
.... S NIEN=0 F S NIEN=$O(@TMP@(TYPE,PRBIEN,BGO,NIEN)) Q:NIEN="" D
..... NEW NNT,L
..... S NNT=$P($G(@TMP@(TYPE,PRBIEN,BGO,NIEN)),U,2)
..... S L=$E(NOTE,$L(NOTE))
..... S NOTE=NOTE_$S(NOTE]"":$C(13)_$C(10),1:"")_NNT
... Q:NOTE=""
... ;
... ;Note Status
... S NSTS="A"
... I DEDD]"",DTTM'<BRNG,DTTM'>ERNG S NSTS="C"
... I ((TYPE="G")!(TYPE="C")),$P(APIRES,U,6)="A" S NSTS="C"
... ;
... ;Set Inactive Goals/Care Plans
... S ACT=""
... I ((TYPE="G")!(TYPE="C")),$P(APIRES,U,6)'="A" S ACT="(i) ",NSTS="A"
... ;
... ;Determined signed/unsigned
... S SIGN=$S(TYPE="T":"",SIGN]"":"S",1:"U")
... ;
... ;Set up record
... S NOTES=NOTES_$S(NOTES]"":C8,1:"")_$S(TYPE="E":"T",1:TYPE)_C9_NIEN_C9_VISIT_C9_VDT_C9_NSTS_C9_$$FMTE^BJPNPRL($P(DTTM,"."),"5ZD")_C9_MDBY_C9_ACT_NOTE_C9_ILMBY_C9_SIGN
. ;
. ;Log entry
. S II=II+1,@DATA@(II)=PIPIEN_U_PRBIEN_U_U_NOTES_$C(30)
;
XNOTES S II=II+1,@DATA@(II)=$C(31)
Q
;
SCHK(DATA,PRIEN,EXCVIEN) ;EP - BJPN CHECK PRB STATUS
;
;This RPC accepts an IPL problem IEN and returns whether the scope can be changed.
;The scope can only be changed to prior if there is no VI, OB, TR, ED for the current
;pregnancy.
;
;Input: PRIEN - Problem IEN
; EXCVIEN - Exclude VIEN in POV check
;
NEW UID,II,DEL,CSCP,CDEL,DFN,TMP,BGO,API,GGO,CGO,CPGSTS,NEDT,BRNG,ERNG,DEDD
NEW VGO,VOB,VTR,VED,VTYPE,APIRES,PIPIEN,X,SIEN,STATUS,RET,NIEN,PIEN
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNGNOT",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNGNOT D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Verify PRIEN was entered
I $G(PRIEN)="" G XSCHK
S EXCVIEN=$G(EXCVIEN)
;
S DFN=$$GET1^DIQ(9000011,PRIEN_",",.02,"I")
;
;Preset to yes
S CSCP="Y",CDEL="Y^"
;Set up Header
S @DATA@(II)="T00001ALLOW_PRIOR^T00001CAN_DELETE^T01024CANNOT_DELETE_REASON"_$C(30)
;
;Check if problem deleted
S DEL=$$GET1^DIQ(9000011,PRIEN_",",2.02,"I") I DEL]"" S II=II+1,@DATA@(II)="^^Problem has already been deleted"_$C(30) G XSCHK
;
;Definitive EDD date range check
D GETPAR^CIAVMRPC(.NEDT,"BJPN POST DEDD DAYS","SYS",1,"I","")
;
;If blank default to 70
I +$G(NEDT)<1 S NEDT=70
;
;Pull the PIPIEN and DEDD, Pregnancy Window
S (DEDD,BRNG,ERNG,PIPIEN)=""
S PIEN="" F S PIEN=$O(^BJPNPL("E",PRIEN,PIEN),-1) Q:PIEN="" D I PIPIEN]"" Q
. Q:$$GET1^DIQ(90680.01,PIEN_",",2.01,"I")]"" ;Exclude deletes
. S PIPIEN=PIEN
;
I PIPIEN]"" D
. NEW X1,X2,X
. S DEDD=$$GET1^DIQ(90680.01,PIPIEN_",",.09,"I")
. S X1=DEDD,X2=-280 D C^%DTC S BRNG=X
. S X1=DEDD,X2=NEDT D C^%DTC S ERNG=X
;
;The following code was adapted from CHK^BGOPROB2. Rather than make that call it was placed here
;so that extra code could be inserted to check for VI/OB in the pregnancy window
;
;CHK(RET,PRIEN) ;Check to see if it is OK to delete a problem
;Check and see if there are any V Care Plan entries for this problem
;If there are, the problem cannot be deleted Patch 13&14
S RET=1
I +$O(^AUPNPROB(+PRIEN,14,"B",0))!(+$O(^AUPNPROB(+PRIEN,15,"B",0))) D
. NEW PTTYP
. ;
. S CDEL="^Problem has been used for a visit and cannot be deleted. Check Problem Details.",RET=-1
. ;
. F PTTYP=14,15 D Q:CSCP=""
.. NEW VIEN
.. ;
.. ;Loop through visits on problem for I/O types
.. S VIEN="" F S VIEN=$O(^AUPNPROB(+PRIEN,PTTYP,"B",VIEN)) Q:VIEN="" D I CSCP="" Q
... ;
... ;Filter out visit if it was just unchecked
... I EXCVIEN>0,EXCVIEN=VIEN Q
... ;
... NEW NSTS,DTTM
... ;Check if POV in pregnancy window
... S NSTS="A"
... S DTTM=$$GET1^DIQ(9000010,VIEN,".01","I")
... I DEDD]"",DTTM'<BRNG,DTTM'>ERNG S NSTS="C"
... I NSTS="C" S CSCP=""
;
;Look for care plan or Goal
S X=0 I RET=1 F S X=$O(^AUPNCPL("B",+PRIEN,X)) Q:X=""!(+RET<0) D
. S SIEN=$C(0) S SIEN=$O(^AUPNCPL(X,11,SIEN),-1)
. S STATUS=$P($G(^AUPNCPL(X,11,SIEN,0)),U,1)
. I STATUS'="E" S CDEL="^Care Plan entries are stored. Check Problem Details. Problem cannot be deleted",RET=-1
;
;Look for visit instructions
S NIEN=0 F S NIEN=$O(^AUPNVVI("B",+PRIEN,NIEN)) Q:NIEN=""!(CSCP="") D
. NEW NSTS,DTTM
. I $$GET1^DIQ(9000010.58,X,.06,"I")=1 Q
. I RET=1 S CDEL="^Visit instructions are stored. Check Problem Details. Problem cannot be deleted",RET=-1
. ;
. S NSTS="A"
. S DTTM=$$GET1^DIQ(9000010.58,NIEN_",",1216,"I")
. I DEDD]"",DTTM'<BRNG,DTTM'>ERNG S NSTS="C"
. I NSTS="C" S CSCP=""
;
;Look for OB notes
I CSCP="Y" S NIEN=0 F S NIEN=$O(^AUPNVOB("B",+PRIEN,NIEN)) Q:NIEN=""!(CSCP="") D
. NEW NSTS,DTTM
. I $$GET1^DIQ(9000010.43,NIEN,.06,"I")=1 Q
. I RET=1 S CDEL="^OB notes are stored. Check Problem Details. Problem cannot be deleted",RET=-1
. ;
. S NSTS="A"
. S DTTM=$$GET1^DIQ(9000010.43,NIEN_",",1216,"I")
. I DEDD]"",DTTM'<BRNG,DTTM'>ERNG S NSTS="C"
. I NSTS="C" S CSCP=""
;
S II=II+1,@DATA@(II)=CSCP_U_CDEL_$C(30)
;
XSCHK S II=II+1,@DATA@(II)=$C(31)
Q
;
LVI(PRBIEN,TMP,VGO,BRNG,CDEL) ;Return latest visit instruction
;
;Since an instruction is on file, cannot delete
S CDEL=""
;
NEW INST,ND,BY,WHEN,NIEN,DTTM
S INST=""
S ND=$G(@TMP@("I",PRBIEN,VGO,0))
S BY=$P(ND,U,12)
S WHEN=$P(ND,U,8)
S NIEN=$P(ND,U,2)
S DTTM=$$GET1^DIQ(9000010.58,NIEN_",",1216,"I")
I DTTM'<BRNG D
. S INST=$P($G(@TMP@("I",PRBIEN,VGO,1)),U,2)
. I INST]"",BY]"" S INST=INST_$C(13)_$C(10)_"Modified by: "_BY_" "_WHEN
Q INST
;
LOB(PRBIEN,TMP,VOB,BRNG,CDEL) ;Return latest OB Note
;
;Since an OB is on file, cannot delete
S CDEL=""
;
NEW OB,ND,BY,WHEN,NIEN,DTTM
S OB=""
S ND=$G(@TMP@("O",PRBIEN,VOB,0))
S BY=$P(ND,U,12)
S WHEN=$P(ND,U,8)
S NIEN=$P(ND,U,2)
S DTTM=$$GET1^DIQ(9000010.43,NIEN_",",1216,"I")
I DTTM'<BRNG D
. S OB=$P($G(@TMP@("O",PRBIEN,VOB,1)),U,2)
. I OB]"",BY]"" S OB=OB_$C(13)_$C(10)_"Modified by: "_BY_" "_WHEN
Q OB
;
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
BJPNGNOT ;GDIT/HS/BEE-Prenatal Care Module Get Note Detail for PIP ; 08 May 2012 12:00 PM
+1 ;;2.0;PRENATAL CARE MODULE;**4,8**;Feb 24, 2015;Build 25
+2 ;
+3 QUIT
+4 ;
NOTES(DATA,DFN,PR,API,TYPE,NOCMP,VIEN) ;EP - BJPN GET PROB NOTES
+1 ;
+2 ;Get BJPN CARE PLANS, GOALS, VISIT INSTRUCTIONS
+3 ;
+4 ;This RPC returns notes entered for problems on the PIP
+5 ;
+6 ;Input: DFN - Patient IEN
+7 ; PR - Problem IEN(s)
+8 ; API - 1 if called from an API (Optional)
+9 ; TYPE - (C) Care Plans, (G) Goals, (I) Visit Instructions,
+10 ; (O) OB Notes, (T) Treatment Plan/Education, null for All
+11 ; NOCMP - (1) Do not recompile data (called by PIP call)
+12 ; VIEN - If passed in, limit visit instructions returned to that visit
+13 ;
+14 SET DFN=$GET(DFN)
SET PR=$GET(PR)
SET API=$GET(API)
SET TYPE=$GET(TYPE)
SET NOCMP=$GET(NOCMP)
+15 IF TYPE'=""
IF TYPE'="C"
IF TYPE'="G"
IF TYPE'="I"
IF TYPE'="T"
IF TYPE'="O"
SET BMXSEC="Invalid TYPE value"
QUIT
+16 ;
+17 NEW UID,II,PIPIEN,SORT,PC,PARY,NEDT,TMP,SIGN,LTYPE,C8,C9
+18 SET UID=$SELECT(API=1:$JOB,$GET(ZTSK):"Z"_ZTSK,1:$JOB)
+19 SET DATA=$NAME(^TMP("BJPNGNOT",UID))
+20 KILL @DATA
+21 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+22 SET VIEN=$GET(VIEN)
+23 ;
+24 ;Define delimiters
+25 SET C8=$CHAR(28)
SET C9=$CHAR(29)
+26 ;
+27 ;Assemble TYPE list
+28 SET LTYPE=$SELECT(TYPE="":"GCIOT",1:TYPE)
IF LTYPE["T"
SET LTYPE=LTYPE_"E"
+29 ;
+30 ;Assemble Problem List Array
+31 IF $GET(PR)]""
FOR II=1:1:$LENGTH(PR,$CHAR(28))
SET PC=$PIECE(PR,$CHAR(28),II)
IF PC]""
SET PARY(PC)=""
+32 ;
+33 SET II=0
+34 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPRL D UNWIND^%ZTER"
+35 ;
+36 ;Define Header
+37 SET @DATA@(II)="I00010PIPIEN^I00010PRBIEN^T00001PREGNANT^T04096NOTES"_$CHAR(30)
+38 ;
+39 ;Verify DFN
+40 IF DFN=""
GOTO XNOTES
+41 ;
+42 ;Definitive EDD date range check
+43 DO GETPAR^CIAVMRPC(.NEDT,"BJPN POST DEDD DAYS","SYS",1,"I","")
+44 ;
+45 ;If blank default to 70
+46 IF +$GET(NEDT)<1
SET NEDT=70
+47 ;
+48 ;Call EHR API and format results into usable data - skip if flag and already compiled
+49 ;Define compiled data reference
SET TMP=$NAME(^TMP("BJPNIPL",UID))
+50 IF '$GET(NOCMP)!($ORDER(@TMP@(""))="")
DO COMP^BJPNUTIL(DFN,UID)
+51 ;
+52 ;Array(n)=Type (G OR C) [1] ^ C Plan IEN [2] ^ Prob IEN [4] ^ Who entered [4] ^ Date Entered [5] ^ Status [6] ^ SIGN FLAG [7]
+53 ; =~t [1] ^ Text of the item [2]
+54 ;Array(n)="I" [1] ^ Instr IEN[2] ^ Prob IEN [3] ^ Vst Date [4] ^ Facility [5] ^ Prv IEN [6] ^ Location [7] ^ Entered Dt [8] ^ Visit IEN [9] ^V cat [10] ^ Locked [11] ^ Prov Name [12] ^ signed [13]
+55 ; =~t [1] ^Text of the item [2]
+56 ;Array(n)="O" [1] ^ Instr IEN[2] ^ Prob IEN [3] ^ Vst Date [4] ^ Facility [5] ^ Prv IEN [6] ^ Location [7] ^ Entered Dt [8] ^ Visit IEN [9] ^V cat [10] ^ Locked [11] ^ Prov Name [12] ^ signed [13]
+57 ; =~t [1] ^Text of the item [2]
+58 ;Array(n)="T" [1] ^ TR IEN[2] ^ SNOMED term [3] ^ Prob IEN [4] ^ Vst Date [5] ^ Facility [6] ^ Prv IEN [7] ^ Location [8] ^ Entered Dt [9] ^ Visit IEN [10] ^ V Cat [11] ^Locked [12] ^ Prov name [13]
+59 ;Array(n)="E" [1] ^ Topic [2] ^ Date [3]
+60 ;
+61 ;Loop through problem list and pull goals and care plans
+62 SET PIPIEN=""
FOR
SET PIPIEN=$ORDER(^BJPNPL("D",DFN,PIPIEN))
IF PIPIEN=""
QUIT
Begin DoDot:1
+63 ;
+64 ;Only include selected problems
+65 IF $DATA(PARY)
IF '$DATA(PARY(PIPIEN))
QUIT
+66 ;
+67 NEW CNT,MDT,BGO,PRBIEN,ITYPE,TYPE,NOTES,DEL
+68 ;
+69 ;Get IPL pointer
+70 SET PRBIEN=$$GET1^DIQ(90680.01,PIPIEN_",",".1","I")
IF PRBIEN=""
QUIT
+71 ;
+72 ;Skip deletes
+73 ;PIP Delete
SET DEL=$$GET1^DIQ(90680.01,PIPIEN_",",2.01,"I")
IF DEL]""
QUIT
+74 ;IPL Delete
SET DEL=$$GET1^DIQ(9000011,PRBIEN_",",2.02,"I")
IF DEL]""
Begin DoDot:2
+75 ;
+76 ;If deleted on IPL, need to delete in PIP
+77 NEW BJPNUPD,ERROR
+78 ;Deleted By
SET BJPNUPD(90680.01,PIPIEN_",",2.01)=$$GET1^DIQ(9000011,PRBIEN_",",2.01,"I")
+79 ;Del Dt/Tm
SET BJPNUPD(90680.01,PIPIEN_",",2.02)=$$GET1^DIQ(9000011,PRBIEN_",",2.02,"I")
+80 ;Del Rsn
SET BJPNUPD(90680.01,PIPIEN_",",2.03)=$$GET1^DIQ(9000011,PRBIEN_",",2.03,"I")
+81 ;Del Other
SET BJPNUPD(90680.01,PIPIEN_",",2.04)=$$GET1^DIQ(9000011,PRBIEN_",",2.04,"I")
+82 DO FILE^DIE("","BJPNUPD","ERROR")
End DoDot:2
QUIT
+83 ;
+84 ;Reset Array variable
+85 SET NOTES=""
+86 ;
+87 ;Loop through by each TYPE
+88 FOR ITYPE=1:1:$LENGTH(LTYPE)
SET TYPE=$EXTRACT(LTYPE,ITYPE)
Begin DoDot:2
+89 ;Loop through compiled results for type
+90 SET BGO=""
FOR
SET BGO=$ORDER(@TMP@(TYPE,PRBIEN,BGO),-1)
IF BGO=""
QUIT
Begin DoDot:3
+91 ;
+92 NEW APIRES,VISIT,DEDD,BRNG,ERNG,NIEN,X1,X2,X,VDT
+93 NEW DTTM,MDBY,ILMBY,NOTE,NSTS,SIGN,ACT
+94 ;
+95 SET SIGN=""
+96 SET APIRES=$GET(@TMP@(TYPE,PRBIEN,BGO,0))
IF APIRES=""
QUIT
+97 ;
+98 ;Pull Visit - If V VISIT INSTRUCTIONS/V OB (GOALS and CARE PLANS are not visit driven)
+99 SET (VISIT,VDT)=""
+100 IF (TYPE="I")!(TYPE="O")
SET VISIT=$PIECE(APIRES,U,9)
SET VDT=$PIECE(APIRES,U,4)
+101 IF TYPE="T"
SET VISIT=$PIECE(APIRES,U,10)
SET VDT=$PIECE(APIRES,U,5)
+102 IF TYPE="E"
Begin DoDot:4
+103 NEW VEDIEN
+104 SET VEDIEN=$PIECE(APIRES,U,6)
IF VEDIEN=""
QUIT
+105 SET VISIT=$$GET1^DIQ(9000010.16,VEDIEN_",",.03,"I")
+106 SET VDT=$$GET1^DIQ(9000010,VISIT,.01,"I")
End DoDot:4
+107 ;
+108 ;Filter on visit
+109 ;BJPN*2.0*4;Do not filter on visit
+110 ;I ((TYPE="I")!(TYPE="T")!(TYPE="E")),VIEN]"",VIEN'=VISIT Q
+111 ;
+112 ;Note IEN (Pointer to entry)
+113 IF TYPE'="E"
SET NIEN=$PIECE(APIRES,U,2)
+114 IF '$TEST
SET NIEN=$PIECE(APIRES,U,6)
+115 IF NIEN=""
QUIT
+116 ;
+117 ;Pull Definitive EDD
+118 SET DEDD=$$GET1^DIQ(90680.01,PIPIEN_",",.09,"I")
+119 SET X1=DEDD
SET X2=-280
DO C^%DTC
SET BRNG=X
+120 SET X1=DEDD
SET X2=NEDT
DO C^%DTC
SET ERNG=X
+121 ;
+122 ;Get note date/time entered and by - V VISIT INSTRUCTIONS
+123 SET (DTTM,ILMBY)=""
+124 IF TYPE="I"
Begin DoDot:4
+125 SET DTTM=$$GET1^DIQ(9000010.58,NIEN_",",1216,"I")
+126 SET ILMBY=$$GET1^DIQ(9000010.58,NIEN_",",1217,"I")
+127 SET SIGN=$PIECE(APIRES,U,13)
End DoDot:4
+128 ;
+129 ;Get note date/time entered and by - V OB
+130 IF TYPE="O"
Begin DoDot:4
+131 SET DTTM=$$GET1^DIQ(9000010.43,NIEN_",",1216,"I")
+132 SET ILMBY=$$GET1^DIQ(9000010.43,NIEN_",",1217,"I")
+133 SET SIGN=$PIECE(APIRES,U,13)
End DoDot:4
+134 ;
+135 ;Get note date/time entered and by - CARE PLAN
+136 IF TYPE'="I"
IF TYPE'="O"
IF TYPE'="T"
IF TYPE'="E"
Begin DoDot:4
+137 NEW IENS,DA
+138 SET DA=$ORDER(^AUPNCPL(NIEN,11,"B","A",""),-1)
IF DA=""
QUIT
+139 SET DA(1)=NIEN
SET IENS=$$IENS^DILF(.DA)
+140 SET DTTM=$$GET1^DIQ(9000092.11,IENS,".03","I")
+141 SET ILMBY=$$GET1^DIQ(9000092.11,IENS,".02","I")
+142 SET SIGN=$PIECE(APIRES,U,7)
End DoDot:4
+143 ;
+144 ;Get treatment plan date/time and by - V TREATMENT/REGIMEN
+145 IF TYPE="T"
Begin DoDot:4
+146 SET DTTM=$$GET1^DIQ(9000010.61,NIEN_",",1216,"I")
+147 SET ILMBY=$$GET1^DIQ(9000010.61,NIEN_",",1217,"I")
End DoDot:4
+148 ;
+149 ;Get education plan date/time and by - V PATIENT ED
+150 IF TYPE="E"
Begin DoDot:4
+151 SET DTTM=$$GET1^DIQ(9000010.16,NIEN_",",1216,"I")
+152 SET ILMBY=$$GET1^DIQ(9000010.16,NIEN_",",1217,"I")
End DoDot:4
+153 ;
+154 IF DTTM=""
QUIT
+155 SET MDBY=$$GET1^DIQ(200,ILMBY_",",".01","E")
+156 ;
+157 ;Get Note
+158 IF TYPE="T"
SET NOTE=$PIECE($GET(@TMP@(TYPE,PRBIEN,BGO,0)),U,14)
+159 IF '$TEST
IF TYPE="E"
SET NOTE=$PIECE(APIRES,U,2)
+160 IF '$TEST
Begin DoDot:4
+161 SET NOTE=""
+162 NEW NIEN
+163 SET NIEN=0
FOR
SET NIEN=$ORDER(@TMP@(TYPE,PRBIEN,BGO,NIEN))
IF NIEN=""
QUIT
Begin DoDot:5
+164 NEW NNT,L
+165 SET NNT=$PIECE($GET(@TMP@(TYPE,PRBIEN,BGO,NIEN)),U,2)
+166 SET L=$EXTRACT(NOTE,$LENGTH(NOTE))
+167 SET NOTE=NOTE_$SELECT(NOTE]"":$CHAR(13)_$CHAR(10),1:"")_NNT
End DoDot:5
End DoDot:4
+168 IF NOTE=""
QUIT
+169 ;
+170 ;Note Status
+171 SET NSTS="A"
+172 IF DEDD]""
IF DTTM'<BRNG
IF DTTM'>ERNG
SET NSTS="C"
+173 IF ((TYPE="G")!(TYPE="C"))
IF $PIECE(APIRES,U,6)="A"
SET NSTS="C"
+174 ;
+175 ;Set Inactive Goals/Care Plans
+176 SET ACT=""
+177 IF ((TYPE="G")!(TYPE="C"))
IF $PIECE(APIRES,U,6)'="A"
SET ACT="(i) "
SET NSTS="A"
+178 ;
+179 ;Determined signed/unsigned
+180 SET SIGN=$SELECT(TYPE="T":"",SIGN]"":"S",1:"U")
+181 ;
+182 ;Set up record
+183 SET NOTES=NOTES_$SELECT(NOTES]"":C8,1:"")_$SELECT(TYPE="E":"T",1:TYPE)_C9_NIEN_C9_VISIT_C9_VDT_C9_NSTS_C9_$$FMTE^BJPNPRL($PIECE(DTTM,"."),"5ZD")_C9_MDBY_C9_ACT_NOTE_C9_ILMBY_C9_SIGN
End DoDot:3
End DoDot:2
+184 ;
+185 ;Log entry
+186 SET II=II+1
SET @DATA@(II)=PIPIEN_U_PRBIEN_U_U_NOTES_$CHAR(30)
End DoDot:1
+187 ;
XNOTES SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
SCHK(DATA,PRIEN,EXCVIEN) ;EP - BJPN CHECK PRB STATUS
+1 ;
+2 ;This RPC accepts an IPL problem IEN and returns whether the scope can be changed.
+3 ;The scope can only be changed to prior if there is no VI, OB, TR, ED for the current
+4 ;pregnancy.
+5 ;
+6 ;Input: PRIEN - Problem IEN
+7 ; EXCVIEN - Exclude VIEN in POV check
+8 ;
+9 NEW UID,II,DEL,CSCP,CDEL,DFN,TMP,BGO,API,GGO,CGO,CPGSTS,NEDT,BRNG,ERNG,DEDD
+10 NEW VGO,VOB,VTR,VED,VTYPE,APIRES,PIPIEN,X,SIEN,STATUS,RET,NIEN,PIEN
+11 ;
+12 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+13 SET DATA=$NAME(^TMP("BJPNGNOT",UID))
+14 KILL @DATA
+15 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+16 ;
+17 SET II=0
+18 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNGNOT D UNWIND^%ZTER"
+19 ;
+20 ;Verify PRIEN was entered
+21 IF $GET(PRIEN)=""
GOTO XSCHK
+22 SET EXCVIEN=$GET(EXCVIEN)
+23 ;
+24 SET DFN=$$GET1^DIQ(9000011,PRIEN_",",.02,"I")
+25 ;
+26 ;Preset to yes
+27 SET CSCP="Y"
SET CDEL="Y^"
+28 ;Set up Header
+29 SET @DATA@(II)="T00001ALLOW_PRIOR^T00001CAN_DELETE^T01024CANNOT_DELETE_REASON"_$CHAR(30)
+30 ;
+31 ;Check if problem deleted
+32 SET DEL=$$GET1^DIQ(9000011,PRIEN_",",2.02,"I")
IF DEL]""
SET II=II+1
SET @DATA@(II)="^^Problem has already been deleted"_$CHAR(30)
GOTO XSCHK
+33 ;
+34 ;Definitive EDD date range check
+35 DO GETPAR^CIAVMRPC(.NEDT,"BJPN POST DEDD DAYS","SYS",1,"I","")
+36 ;
+37 ;If blank default to 70
+38 IF +$GET(NEDT)<1
SET NEDT=70
+39 ;
+40 ;Pull the PIPIEN and DEDD, Pregnancy Window
+41 SET (DEDD,BRNG,ERNG,PIPIEN)=""
+42 SET PIEN=""
FOR
SET PIEN=$ORDER(^BJPNPL("E",PRIEN,PIEN),-1)
IF PIEN=""
QUIT
Begin DoDot:1
+43 ;Exclude deletes
IF $$GET1^DIQ(90680.01,PIEN_",",2.01,"I")]""
QUIT
+44 SET PIPIEN=PIEN
End DoDot:1
IF PIPIEN]""
QUIT
+45 ;
+46 IF PIPIEN]""
Begin DoDot:1
+47 NEW X1,X2,X
+48 SET DEDD=$$GET1^DIQ(90680.01,PIPIEN_",",.09,"I")
+49 SET X1=DEDD
SET X2=-280
DO C^%DTC
SET BRNG=X
+50 SET X1=DEDD
SET X2=NEDT
DO C^%DTC
SET ERNG=X
End DoDot:1
+51 ;
+52 ;The following code was adapted from CHK^BGOPROB2. Rather than make that call it was placed here
+53 ;so that extra code could be inserted to check for VI/OB in the pregnancy window
+54 ;
+55 ;CHK(RET,PRIEN) ;Check to see if it is OK to delete a problem
+56 ;Check and see if there are any V Care Plan entries for this problem
+57 ;If there are, the problem cannot be deleted Patch 13&14
+58 SET RET=1
+59 IF +$ORDER(^AUPNPROB(+PRIEN,14,"B",0))!(+$ORDER(^AUPNPROB(+PRIEN,15,"B",0)))
Begin DoDot:1
+60 NEW PTTYP
+61 ;
+62 SET CDEL="^Problem has been used for a visit and cannot be deleted. Check Problem Details."
SET RET=-1
+63 ;
+64 FOR PTTYP=14,15
Begin DoDot:2
+65 NEW VIEN
+66 ;
+67 ;Loop through visits on problem for I/O types
+68 SET VIEN=""
FOR
SET VIEN=$ORDER(^AUPNPROB(+PRIEN,PTTYP,"B",VIEN))
IF VIEN=""
QUIT
Begin DoDot:3
+69 ;
+70 ;Filter out visit if it was just unchecked
+71 IF EXCVIEN>0
IF EXCVIEN=VIEN
QUIT
+72 ;
+73 NEW NSTS,DTTM
+74 ;Check if POV in pregnancy window
+75 SET NSTS="A"
+76 SET DTTM=$$GET1^DIQ(9000010,VIEN,".01","I")
+77 IF DEDD]""
IF DTTM'<BRNG
IF DTTM'>ERNG
SET NSTS="C"
+78 IF NSTS="C"
SET CSCP=""
End DoDot:3
IF CSCP=""
QUIT
End DoDot:2
IF CSCP=""
QUIT
End DoDot:1
+79 ;
+80 ;Look for care plan or Goal
+81 SET X=0
IF RET=1
FOR
SET X=$ORDER(^AUPNCPL("B",+PRIEN,X))
IF X=""!(+RET<0)
QUIT
Begin DoDot:1
+82 SET SIEN=$CHAR(0)
SET SIEN=$ORDER(^AUPNCPL(X,11,SIEN),-1)
+83 SET STATUS=$PIECE($GET(^AUPNCPL(X,11,SIEN,0)),U,1)
+84 IF STATUS'="E"
SET CDEL="^Care Plan entries are stored. Check Problem Details. Problem cannot be deleted"
SET RET=-1
End DoDot:1
+85 ;
+86 ;Look for visit instructions
+87 SET NIEN=0
FOR
SET NIEN=$ORDER(^AUPNVVI("B",+PRIEN,NIEN))
IF NIEN=""!(CSCP="")
QUIT
Begin DoDot:1
+88 NEW NSTS,DTTM
+89 IF $$GET1^DIQ(9000010.58,X,.06,"I")=1
QUIT
+90 IF RET=1
SET CDEL="^Visit instructions are stored. Check Problem Details. Problem cannot be deleted"
SET RET=-1
+91 ;
+92 SET NSTS="A"
+93 SET DTTM=$$GET1^DIQ(9000010.58,NIEN_",",1216,"I")
+94 IF DEDD]""
IF DTTM'<BRNG
IF DTTM'>ERNG
SET NSTS="C"
+95 IF NSTS="C"
SET CSCP=""
End DoDot:1
+96 ;
+97 ;Look for OB notes
+98 IF CSCP="Y"
SET NIEN=0
FOR
SET NIEN=$ORDER(^AUPNVOB("B",+PRIEN,NIEN))
IF NIEN=""!(CSCP="")
QUIT
Begin DoDot:1
+99 NEW NSTS,DTTM
+100 IF $$GET1^DIQ(9000010.43,NIEN,.06,"I")=1
QUIT
+101 IF RET=1
SET CDEL="^OB notes are stored. Check Problem Details. Problem cannot be deleted"
SET RET=-1
+102 ;
+103 SET NSTS="A"
+104 SET DTTM=$$GET1^DIQ(9000010.43,NIEN_",",1216,"I")
+105 IF DEDD]""
IF DTTM'<BRNG
IF DTTM'>ERNG
SET NSTS="C"
+106 IF NSTS="C"
SET CSCP=""
End DoDot:1
+107 ;
+108 SET II=II+1
SET @DATA@(II)=CSCP_U_CDEL_$CHAR(30)
+109 ;
XSCHK SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
LVI(PRBIEN,TMP,VGO,BRNG,CDEL) ;Return latest visit instruction
+1 ;
+2 ;Since an instruction is on file, cannot delete
+3 SET CDEL=""
+4 ;
+5 NEW INST,ND,BY,WHEN,NIEN,DTTM
+6 SET INST=""
+7 SET ND=$GET(@TMP@("I",PRBIEN,VGO,0))
+8 SET BY=$PIECE(ND,U,12)
+9 SET WHEN=$PIECE(ND,U,8)
+10 SET NIEN=$PIECE(ND,U,2)
+11 SET DTTM=$$GET1^DIQ(9000010.58,NIEN_",",1216,"I")
+12 IF DTTM'<BRNG
Begin DoDot:1
+13 SET INST=$PIECE($GET(@TMP@("I",PRBIEN,VGO,1)),U,2)
+14 IF INST]""
IF BY]""
SET INST=INST_$CHAR(13)_$CHAR(10)_"Modified by: "_BY_" "_WHEN
End DoDot:1
+15 QUIT INST
+16 ;
LOB(PRBIEN,TMP,VOB,BRNG,CDEL) ;Return latest OB Note
+1 ;
+2 ;Since an OB is on file, cannot delete
+3 SET CDEL=""
+4 ;
+5 NEW OB,ND,BY,WHEN,NIEN,DTTM
+6 SET OB=""
+7 SET ND=$GET(@TMP@("O",PRBIEN,VOB,0))
+8 SET BY=$PIECE(ND,U,12)
+9 SET WHEN=$PIECE(ND,U,8)
+10 SET NIEN=$PIECE(ND,U,2)
+11 SET DTTM=$$GET1^DIQ(9000010.43,NIEN_",",1216,"I")
+12 IF DTTM'<BRNG
Begin DoDot:1
+13 SET OB=$PIECE($GET(@TMP@("O",PRBIEN,VOB,1)),U,2)
+14 IF OB]""
IF BY]""
SET OB=OB_$CHAR(13)_$CHAR(10)_"Modified by: "_BY_" "_WHEN
End DoDot:1
+15 QUIT OB
+16 ;
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
