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
;
Q
;
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)
;
Q
;
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
