Routine: BJPNGNOT

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

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)

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)

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)

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

BJPNGNOT.m