Routine: BJPN20PS

BJPN20PS ;GDIT/HS/BEE-Prenatal Care Module 2.0 Post Install ; 08 May 2012  12:00 PM

 ;;2.0;PRENATAL CARE MODULE;;Feb 24, 2015;Build 63

PST ;EP - Prenatal 2.0 Post Installation Code

 NEW BI,TEXT,DIK,DA

 ;If PRENATAL 1.0 was installed, perform conversion

 D CONV

 ;Recompile the new "E" index (by PROBLEM)

 I +$O(^BJPNPL(0))>0 D

 . W !!,"Recompiling cross references"

 . S DIK="^BJPNPL(" D IXALL2^DIK

 . S DIK="^BJPNPL(" D IXALL^DIK

 ;Recompile the new "E" index (by PROBLEM)

 S DIK="^BJPNPL(",DIK(1)=".1^F" D ENALL^DIK

 ; UPDATE THE VUECENTRIC REGISTERED OBJECTS FILE

 D REG^BJPN20RG

XPST Q

CONV ;Convert existing PIP/VOB entries to use new BJPN SNOMED TERMS entries

 NEW DIK

 ;Only convert if backup from pre-install is present

 Q:'$D(^XTMP("BJPN"))

 ;Process each panel entry

 K ^TMP("BJPNCVVOB",$J)

 S BJPNPL=0 F  S BJPNPL=$O(^BJPNPL(BJPNPL)) Q:'BJPNPL  D

 . NEW STS

 . S STS=$$PRC1PIP(BJPNPL)

 K ^TMP("BJPNCVVOB",$J)

PRC1PIP(BJPNPL) ;EP - Process one PIP entry

 ;In a number of cases FileMan sets cannot be used as they would cause invalid audit entries

 ;to be generated.  The audit entries get set up manually where needed

 NEW BJPNSMD,CONCID,CONSTR,DESCID,DFN,PIEN,PRBIEN,PROBLEM,STS,ICD,AUPNPROB,CPREG

 NEW PEDD,DEDD,ERROR,DESCSTR,IENS,DA,DIK,NEWPRB,LMB,LMD,ENB,END

 ;Check to see if the PROBLEM field is populated, if so conversion completed

 S PROBLEM=$$GET1^DIQ(90680.01,BJPNPL_",",".1","I") I PROBLEM]"" S STS="2^PIP entry already converted" Q STS

 ;Skip deleted problem entries

 I $$GET1^DIQ(90680.01,BJPNPL_",","2.02","I")]"" S STS="0^PIP Problem has been deleted" Q STS

 ;Get the SNOMED 90620.02 file pointer

 S BJPNSMD=$$GET1^DIQ(90680.01,BJPNPL_",",".03","I") I BJPNSMD="" S STS="0^Invalid SNOMED pointer" Q STS

 ;Get the Concept ID - Quit if invalid

 W !,"Processing Prenatal PIP entry: ",BJPNPL

 S CONCID=$$GET1^DIQ(90680.02,BJPNSMD_",",".07","I") I CONCID="" S STS="0^Missing Concept ID" Q STS

 S CONSTR=$$CONC^BSTSAPI(CONCID_"^^^1") I $P(CONSTR,U,2)="" S STS="0^DTS could not find Concept ID" Q STS

 ;Get the description ID - If invalid, use preferred term

 S DESCID=$$GET1^DIQ(90680.02,BJPNSMD_",",".03","I")

 S:DESCID="" DESCID=$P(CONSTR,U,3) I DESCID="" S STS="0^Could not locate Description ID" Q STS

 S DESCSTR=$$DESC^BSTSAPI(DESCID_"^^1") I $P(DESCSTR,U)="" S STS="0^DTS could not find Description ID" Q STS

 ;Valid Concept ID and Description Id found - ok to continue

 ;Get the patient DFN

 S DFN=$$GET1^DIQ(90680.01,BJPNPL_",",".02","I") I DFN="" S STS="0^Missing DFN in ^BJPNPL" Q STS

 ;Check to see if we have a problem on the IPL already

 S (PRBIEN,PIEN,NEWPRB)="" F  S PIEN=$O(^AUPNPROB("APCT",DFN,CONCID,PIEN)) Q:'PIEN  D  I PRBIEN]"" Q

 . NEW DELPRB

 . S DELPRB=$$GET1^DIQ(9000011,PIEN_",",2.02,"I") I DELPRB]"" Q  ;Skip deletes

 . S PRBIEN=PIEN  ;Found a match

 ;Get the ICD code

 S DA=1,DA(1)=BJPNSMD S IENS=$$IENS^DILF(.DA)

 S ICD=$$GET1^DIQ(90680.21,IENS,".01","I")

 I ICD="" D  I ICD="" S STS="0^Missing ICD Code" Q STS

 . NEW X,DIC,X,Y

 . S X=".9999" I $$VERSION^XPDUTL("AICD")>3.51,$T(IMP^ICDEXA)]"",$$IMP^ICDEXA(30)>DT S X="ZZZ.999"

 . S DIC="^ICD9(",DIC(0)="XMO" D ^DIC I +Y<0 S ICD="" Q

 . S ICD=+Y

 ;If new problem, create new entry, quit if one wasn't created

 I PRBIEN="" D  Q:'+STS

 . S NEWPRB=1 ;Record that this is a new problem being added

 . NEW RET,VIEN,FRSTIEN,LIST,NARR,LOC,PRBCNT,Y,PIP,DA,DIK

. ;

 . S STS=0

. ;

 . ;Get the visit IEN that the problem was added

 . S FRSTIEN=$O(^AUPNVOB("B",BJPNPL,""))

 . S VIEN=$$GET1^DIQ(9000010.43,FRSTIEN_",",".03","I") I VIEN="" S STS="0^No visit found" Q

. ;

 . ;Get the provider text - now provider text | descriptive SNOMED CT

 . S NARR=$$GET1^DIQ(90680.01,BJPNPL_",",".05","E")

. ;

 . ;Get the location

 . S LOC=$$GET1^DIQ(9000010,VIEN_",",".06","I")

. ;

 . ;Get the next problem #

 . D NEXTID^BGOPROB(.RET,DFN)

 . S PRBCNT=+$P(RET,"-",2)

. ;

 . ;  DFN   = Patient IEN

 . ;  PRIEN = IEN of problem, null if new

 . ;  VIEN  = Needed if asthma DX

 . ;  List(n)

 . ;        "P"[1] ^ SNOMED CT [2] ^ Descriptive CT [3] ^ Provider text [4] ^ Mapped ICD [5]

 . ;        ^ Location [6] ^ Date of Onset [7] ^ Status [8] ^ Class [9] ^Problem # [10] ^ Priority [11] ^ INP DX [12]

 . ;        "A"[1] ^ Classification [2] ^ Control [3] ^ V asthma IEN [4]

 . ;        "Q"[1] ^ TYPE [2] ^ Qualifier IEN [3] ^ Qual SNOMED [4] ^ By [5] ^ When [6] ^ Delete [7]

 . ;SET(RET,DFN,PRIEN,VIEN,ARRAY) ;EP

 . S LIST(0)="P"_U_CONCID_U_DESCID_U_NARR_U_ICD_U_LOC_U_U_"Episodic"_U_U_PRBCNT_U_"0"

. ;

 . ;Turn off auditing

 . NEW AFLD,AI,RES F AI=.01,.03,.05,.12,80001,80002,"1401,.01","1501,.01" S RES=$$OFF^BJPN20AU(9000011,AI) S:RES]"" AFLD(AI)=RES

. ;

 . ;Log the problem

 . D SET^BGOPROB(.RET,DFN,"",VIEN,.LIST)

. ;

 . ;Perform BUSA audit

 . D LOG^BJPNUTIL("P","A","BJPN20PS","Added problem to IPL/PIP",DFN)

. ;

 . ;Turn auditing back on

 . S AI="" F  S AI=$O(AFLD(AI)) Q:AI=""  D ON^BJPN20AU(9000011,AI,AFLD(AI))

 . K AFLD,AI,RES

. ;

 . I '+RET S STS="0^Could not create new problem entry" Q

 . S PRBIEN=+RET

. ;

 . ;Return success

 . S STS=1

 ;If Problem IEN present, update PIP file

 I PRBIEN]"" S $P(^BJPNPL(BJPNPL,0),U,10)=PRBIEN

 ;Determine whether to check the PIP box in the problem file

 S CPREG=$$GET1^DIQ(9000017,DFN_",",1101,"I")  ;Currently pregnant

 S DEDD=$$GET1^DIQ(9000017,DFN_",",1311,"I")   ;Definitive EDD

 S PEDD=$$DEDD^BJPNPDET(DFN)                   ;Definitive EDD - PIP

 ;If we have currently pregnant and definitive EDD, mark PIP

 S PIP="" I CPREG="Y",DEDD]"" S PIP=1

 ;Not pregnant, but PIP EDD is still defined - meaning PIP has not been closed

 I CPREG'="Y",PEDD]"" S PIP=1

 ;PIP entry is inactive - never mark PIP

 I $$GET1^DIQ(90680.01,BJPNPL_",",".08","I")'="A" S PIP=""

 ;File the entry

 S $P(^AUPNPROB(PRBIEN,0),U,19)=PIP

 ;If existing problem retrieve modified/entered info

 I 'NEWPRB D

 . S LMB=$$GET1^DIQ(9000011,PRBIEN,".14","I")

 . S LMD=$$GET1^DIQ(9000011,PRBIEN,".03","I")

 . S END=$$GET1^DIQ(9000011,PRBIEN,".08","I")

 . S ENB=$$GET1^DIQ(9000011,PRBIEN,"1.03","I")

 ;If existing problem, back up current POVs)

 I 'NEWPRB D

 . NEW TYPE,VSIEN

 . F TYPE=14,15 S VSIEN="" F  S VSIEN=$O(^AUPNPROB(PRBIEN,TYPE,"B",VSIEN)) Q:VSIEN=""  S ^TMP("BJPNCVVOB",$J,PRBIEN,TYPE,VSIEN)=""

 ;Copy Care Plan Notes to Visit Instructions, POV info, auditing

 D VOB^BJPN20P1(BJPNPL,PRBIEN,NEWPRB)

 ;Turn off auditing

 NEW AFLD,AI,RES F AI=.01,.03,.05,.12,80001,80002,"1401,.01","1501,.01" S RES=$$OFF^BJPN20AU(9000011,AI) S:RES]"" AFLD(AI)=RES

 ;Get the current problem ICD - we may need to change it to the one passed in

 NEW CICD

 S CICD=$$GET1^DIQ(9000011,PRBIEN_",",.01,"I")

 I CICD'=ICD,ICD]"" D

 . NEW AUPN,ERROR

 . S AUPN(9000011,PRBIEN_",",".01")=ICD

 . D FILE^DIE("","AUPN","ERROR")

 K CICD

 ;Now re-index again

 S DA=PRBIEN,DIK="^AUPNPROB(" D IX^DIK

 ;Determine which enter/last modified information to use

 I 'NEWPRB D

 . NEW CLMD,CEND,AUPN,ERROR

. ;

 . ;Use latest last modified information

 . S CLMD=$$GET1^DIQ(9000011,PRBIEN,".03","I")

 . I CLMD]"",CLMD<$G(LMD) D

 .. S AUPN(9000011,PRBIEN_",",".03")=LMD

 .. S AUPN(9000011,PRBIEN_",",".14")=$G(LMB)

.;

 .;Use earliest entered by information

 . S CEND=$$GET1^DIQ(9000011,PRBIEN,".08","I")

 . I $G(END)]"",END<CEND D

 .. S AUPN(9000011,PRBIEN_",",".08")=END

 .. S AUPN(9000011,PRBIEN_",","1.03")=$G(ENB)

. ;

 . ;File any changes

 . I $D(AUPN) D FILE^DIE("","AUPN","ERROR")

 ;Turn auditing back on

 S AI="" F  S AI=$O(AFLD(AI)) Q:AI=""  D ON^BJPN20AU(9000011,AI,AFLD(AI))

 K AFLD,AI,RES

Q 1

BJPN20PS  ;GDIT/HS/BEE-Prenatal Care Module 2.0 Post Install ; 08 May 2012  12:00 PM

 +1       ;;2.0;PRENATAL CARE MODULE;;Feb 24, 2015;Build 63

 +2       ;

 +3        QUIT

 +4       ;

PST       ;EP - Prenatal 2.0 Post Installation Code

 +1       ;

 +2        NEW BI,TEXT,DIK,DA

 +3       ;

 +4       ;If PRENATAL 1.0 was installed, perform conversion

 +5        DO CONV

 +6       ;

 +7       ;Recompile the new "E" index (by PROBLEM)

 +8        IF +$ORDER(^BJPNPL(0))>0

               Begin DoDot:1

 +9                WRITE !!,"Recompiling cross references"

 +10               SET DIK="^BJPNPL("

                   DO IXALL2^DIK

 +11               SET DIK="^BJPNPL("

                   DO IXALL^DIK

               End DoDot:1

 +12      ;

 +13      ;Recompile the new "E" index (by PROBLEM)

 +14       SET DIK="^BJPNPL("

           SET DIK(1)=".1^F"

           DO ENALL^DIK

 +15      ;

 +16      ; UPDATE THE VUECENTRIC REGISTERED OBJECTS FILE

 +17       DO REG^BJPN20RG

 +18      ;

XPST       QUIT

 +1       ;

CONV      ;Convert existing PIP/VOB entries to use new BJPN SNOMED TERMS entries

 +1       ;

 +2        NEW DIK

 +3       ;

 +4       ;Only convert if backup from pre-install is present

 +5        IF '$DATA(^XTMP("BJPN"))

               QUIT

 +6       ;

 +7       ;Process each panel entry

 +8        KILL ^TMP("BJPNCVVOB",$JOB)

 +9        SET BJPNPL=0

FOR

               SET BJPNPL=$ORDER(^BJPNPL(BJPNPL))

               IF 'BJPNPL

                   QUIT

               Begin DoDot:1

 +10               NEW STS

 +11               SET STS=$$PRC1PIP(BJPNPL)

               End DoDot:1

 +12       KILL ^TMP("BJPNCVVOB",$JOB)

 +13      ;

 +14       QUIT

 +15      ;

PRC1PIP(BJPNPL) ;EP - Process one PIP entry

 +1       ;

 +2       ;In a number of cases FileMan sets cannot be used as they would cause invalid audit entries

 +3       ;to be generated.  The audit entries get set up manually where needed

 +4       ;

 +5        NEW BJPNSMD,CONCID,CONSTR,DESCID,DFN,PIEN,PRBIEN,PROBLEM,STS,ICD,AUPNPROB,CPREG

 +6        NEW PEDD,DEDD,ERROR,DESCSTR,IENS,DA,DIK,NEWPRB,LMB,LMD,ENB,END

 +7       ;

 +8       ;Check to see if the PROBLEM field is populated, if so conversion completed

 +9        SET PROBLEM=$$GET1^DIQ(90680.01,BJPNPL_",",".1","I")

           IF PROBLEM]""

               SET STS="2^PIP entry already converted"

               QUIT STS

 +10      ;

 +11      ;Skip deleted problem entries

 +12       IF $$GET1^DIQ(90680.01,BJPNPL_",","2.02","I")]""

               SET STS="0^PIP Problem has been deleted"

               QUIT STS

 +13      ;

 +14      ;Get the SNOMED 90620.02 file pointer

 +15       SET BJPNSMD=$$GET1^DIQ(90680.01,BJPNPL_",",".03","I")

           IF BJPNSMD=""

               SET STS="0^Invalid SNOMED pointer"

               QUIT STS

 +16      ;

 +17      ;Get the Concept ID - Quit if invalid

 +18       WRITE !,"Processing Prenatal PIP entry: ",BJPNPL

 +19       SET CONCID=$$GET1^DIQ(90680.02,BJPNSMD_",",".07","I")

           IF CONCID=""

               SET STS="0^Missing Concept ID"

               QUIT STS

 +20       SET CONSTR=$$CONC^BSTSAPI(CONCID_"^^^1")

           IF $PIECE(CONSTR,U,2)=""

               SET STS="0^DTS could not find Concept ID"

               QUIT STS

 +21      ;

 +22      ;Get the description ID - If invalid, use preferred term

 +23       SET DESCID=$$GET1^DIQ(90680.02,BJPNSMD_",",".03","I")

 +24       IF DESCID=""

               SET DESCID=$PIECE(CONSTR,U,3)

           IF DESCID=""

               SET STS="0^Could not locate Description ID"

               QUIT STS

 +25       SET DESCSTR=$$DESC^BSTSAPI(DESCID_"^^1")

           IF $PIECE(DESCSTR,U)=""

               SET STS="0^DTS could not find Description ID"

               QUIT STS

 +26      ;

 +27      ;Valid Concept ID and Description Id found - ok to continue

 +28      ;

 +29      ;Get the patient DFN

 +30       SET DFN=$$GET1^DIQ(90680.01,BJPNPL_",",".02","I")

           IF DFN=""

               SET STS="0^Missing DFN in ^BJPNPL"

               QUIT STS

 +31      ;

 +32      ;Check to see if we have a problem on the IPL already

 +33       SET (PRBIEN,PIEN,NEWPRB)=""

FOR

               SET PIEN=$ORDER(^AUPNPROB("APCT",DFN,CONCID,PIEN))

               IF 'PIEN

                   QUIT

               Begin DoDot:1

 +34               NEW DELPRB

 +35      ;Skip deletes

                   SET DELPRB=$$GET1^DIQ(9000011,PIEN_",",2.02,"I")

                   IF DELPRB]""

                       QUIT

 +36      ;Found a match

                   SET PRBIEN=PIEN

               End DoDot:1

               IF PRBIEN]""

                   QUIT

 +37      ;

 +38      ;Get the ICD code

 +39       SET DA=1

           SET DA(1)=BJPNSMD

           SET IENS=$$IENS^DILF(.DA)

 +40       SET ICD=$$GET1^DIQ(90680.21,IENS,".01","I")

 +41      ;

 +42       IF ICD=""

               Begin DoDot:1

 +43               NEW X,DIC,X,Y

 +44               SET X=".9999"

                   IF $$VERSION^XPDUTL("AICD")>3.51

                       IF $TEXT(IMP^ICDEXA)]""

                           IF $$IMP^ICDEXA(30)>DT

                               SET X="ZZZ.999"

 +45               SET DIC="^ICD9("

                   SET DIC(0)="XMO"

                   DO ^DIC

                   IF +Y<0

                       SET ICD=""

                       QUIT

 +46               SET ICD=+Y

               End DoDot:1

               IF ICD=""

                   SET STS="0^Missing ICD Code"

                   QUIT STS

 +47      ;

 +48      ;If new problem, create new entry, quit if one wasn't created

 +49       IF PRBIEN=""

               Begin DoDot:1

 +50      ;Record that this is a new problem being added

                   SET NEWPRB=1

 +51               NEW RET,VIEN,FRSTIEN,LIST,NARR,LOC,PRBCNT,Y,PIP,DA,DIK

 +52      ;

 +53               SET STS=0

 +54      ;

 +55      ;Get the visit IEN that the problem was added

 +56               SET FRSTIEN=$ORDER(^AUPNVOB("B",BJPNPL,""))

 +57               SET VIEN=$$GET1^DIQ(9000010.43,FRSTIEN_",",".03","I")

                   IF VIEN=""

                       SET STS="0^No visit found"

                       QUIT

 +58      ;

 +59      ;Get the provider text - now provider text | descriptive SNOMED CT

 +60               SET NARR=$$GET1^DIQ(90680.01,BJPNPL_",",".05","E")

 +61      ;

 +62      ;Get the location

 +63               SET LOC=$$GET1^DIQ(9000010,VIEN_",",".06","I")

 +64      ;

 +65      ;Get the next problem #

 +66               DO NEXTID^BGOPROB(.RET,DFN)

 +67               SET PRBCNT=+$PIECE(RET,"-",2)

 +68      ;

 +69      ;  DFN   = Patient IEN

 +70      ;  PRIEN = IEN of problem, null if new

 +71      ;  VIEN  = Needed if asthma DX

 +72      ;  List(n)

 +73      ;        "P"[1] ^ SNOMED CT [2] ^ Descriptive CT [3] ^ Provider text [4] ^ Mapped ICD [5]

 +74      ;        ^ Location [6] ^ Date of Onset [7] ^ Status [8] ^ Class [9] ^Problem # [10] ^ Priority [11] ^ INP DX [12]

 +75      ;        "A"[1] ^ Classification [2] ^ Control [3] ^ V asthma IEN [4]

 +76      ;        "Q"[1] ^ TYPE [2] ^ Qualifier IEN [3] ^ Qual SNOMED [4] ^ By [5] ^ When [6] ^ Delete [7]

 +77      ;SET(RET,DFN,PRIEN,VIEN,ARRAY) ;EP

 +78               SET LIST(0)="P"_U_CONCID_U_DESCID_U_NARR_U_ICD_U_LOC_U_U_"Episodic"_U_U_PRBCNT_U_"0"

 +79      ;

 +80      ;Turn off auditing

 +81               NEW AFLD,AI,RES

                   FOR AI=.01,.03,.05,.12,80001,80002,"1401,.01","1501,.01"

                       SET RES=$$OFF^BJPN20AU(9000011,AI)

                       IF RES]""

                           SET AFLD(AI)=RES

 +82      ;

 +83      ;Log the problem

 +84               DO SET^BGOPROB(.RET,DFN,"",VIEN,.LIST)

 +85      ;

 +86      ;Perform BUSA audit

 +87               DO LOG^BJPNUTIL("P","A","BJPN20PS","Added problem to IPL/PIP",DFN)

 +88      ;

 +89      ;Turn auditing back on

 +90               SET AI=""

FOR

                       SET AI=$ORDER(AFLD(AI))

                       IF AI=""

                           QUIT

                       DO ON^BJPN20AU(9000011,AI,AFLD(AI))

 +91               KILL AFLD,AI,RES

 +92      ;

 +93               IF '+RET

                       SET STS="0^Could not create new problem entry"

                       QUIT

 +94               SET PRBIEN=+RET

 +95      ;

 +96      ;Return success

 +97               SET STS=1

               End DoDot:1

               IF '+STS

                   QUIT

 +98      ;

 +99      ;If Problem IEN present, update PIP file

 +100      IF PRBIEN]""

               SET $PIECE(^BJPNPL(BJPNPL,0),U,10)=PRBIEN

 +101     ;

 +102     ;Determine whether to check the PIP box in the problem file

 +103     ;Currently pregnant

           SET CPREG=$$GET1^DIQ(9000017,DFN_",",1101,"I")

 +104     ;Definitive EDD

           SET DEDD=$$GET1^DIQ(9000017,DFN_",",1311,"I")

 +105     ;Definitive EDD - PIP

           SET PEDD=$$DEDD^BJPNPDET(DFN)

 +106     ;

 +107     ;If we have currently pregnant and definitive EDD, mark PIP

 +108      SET PIP=""

           IF CPREG="Y"

               IF DEDD]""

                   SET PIP=1

 +109     ;

 +110     ;Not pregnant, but PIP EDD is still defined - meaning PIP has not been closed

 +111      IF CPREG'="Y"

               IF PEDD]""

                   SET PIP=1

 +112     ;

 +113     ;PIP entry is inactive - never mark PIP

 +114      IF $$GET1^DIQ(90680.01,BJPNPL_",",".08","I")'="A"

               SET PIP=""

 +115     ;

 +116     ;File the entry

 +117      SET $PIECE(^AUPNPROB(PRBIEN,0),U,19)=PIP

 +118     ;

 +119     ;If existing problem retrieve modified/entered info

 +120      IF 'NEWPRB

               Begin DoDot:1

 +121              SET LMB=$$GET1^DIQ(9000011,PRBIEN,".14","I")

 +122              SET LMD=$$GET1^DIQ(9000011,PRBIEN,".03","I")

 +123              SET END=$$GET1^DIQ(9000011,PRBIEN,".08","I")

 +124              SET ENB=$$GET1^DIQ(9000011,PRBIEN,"1.03","I")

               End DoDot:1

 +125     ;

 +126     ;If existing problem, back up current POVs)

 +127      IF 'NEWPRB

               Begin DoDot:1

 +128              NEW TYPE,VSIEN

 +129              FOR TYPE=14,15

                       SET VSIEN=""

FOR

                           SET VSIEN=$ORDER(^AUPNPROB(PRBIEN,TYPE,"B",VSIEN))

                           IF VSIEN=""

                               QUIT

                           SET ^TMP("BJPNCVVOB",$JOB,PRBIEN,TYPE,VSIEN)=""

               End DoDot:1

 +130     ;

 +131     ;Copy Care Plan Notes to Visit Instructions, POV info, auditing

 +132      DO VOB^BJPN20P1(BJPNPL,PRBIEN,NEWPRB)

 +133     ;

 +134     ;Turn off auditing

 +135      NEW AFLD,AI,RES

           FOR AI=.01,.03,.05,.12,80001,80002,"1401,.01","1501,.01"

               SET RES=$$OFF^BJPN20AU(9000011,AI)

               IF RES]""

                   SET AFLD(AI)=RES

 +136     ;

 +137     ;Get the current problem ICD - we may need to change it to the one passed in

 +138      NEW CICD

 +139      SET CICD=$$GET1^DIQ(9000011,PRBIEN_",",.01,"I")

 +140      IF CICD'=ICD

               IF ICD]""

                   Begin DoDot:1

 +141                  NEW AUPN,ERROR

 +142                  SET AUPN(9000011,PRBIEN_",",".01")=ICD

 +143                  DO FILE^DIE("","AUPN","ERROR")

                   End DoDot:1

 +144      KILL CICD

 +145     ;

 +146     ;Now re-index again

 +147      SET DA=PRBIEN

           SET DIK="^AUPNPROB("

           DO IX^DIK

 +148     ;

 +149     ;Determine which enter/last modified information to use

 +150      IF 'NEWPRB

               Begin DoDot:1

 +151              NEW CLMD,CEND,AUPN,ERROR

 +152     ;

 +153     ;Use latest last modified information

 +154              SET CLMD=$$GET1^DIQ(9000011,PRBIEN,".03","I")

 +155              IF CLMD]""

                       IF CLMD<$GET(LMD)

                           Begin DoDot:2

 +156                          SET AUPN(9000011,PRBIEN_",",".03")=LMD

 +157                          SET AUPN(9000011,PRBIEN_",",".14")=$GET(LMB)

                           End DoDot:2

 +158     ;

 +159     ;Use earliest entered by information

 +160              SET CEND=$$GET1^DIQ(9000011,PRBIEN,".08","I")

 +161              IF $GET(END)]""

                       IF END<CEND

                           Begin DoDot:2

 +162                          SET AUPN(9000011,PRBIEN_",",".08")=END

 +163                          SET AUPN(9000011,PRBIEN_",","1.03")=$GET(ENB)

                           End DoDot:2

 +164     ;

 +165     ;File any changes

 +166              IF $DATA(AUPN)

                       DO FILE^DIE("","AUPN","ERROR")

               End DoDot:1

 +167     ;

 +168     ;Turn auditing back on

 +169      SET AI=""

FOR

               SET AI=$ORDER(AFLD(AI))

               IF AI=""

                   QUIT

               DO ON^BJPN20AU(9000011,AI,AFLD(AI))

 +170      KILL AFLD,AI,RES

 +171     ;

 +172      QUIT 1

BJPN20PS.m