BJPNPUP ;GDIT/HS/BEE-Prenatal Care Module Problem Handling Code ; 08 May 2012 12:00 PM
;;2.0;PRENATAL CARE MODULE;;Feb 24, 2015;Build 63
;
Q
;
ADD(DATA,VIEN,PRIEN,PARMS) ;EP - BJPN SET PRB FROM PIP
;
;Input:
; VIEN - Visit IEN
; PRIEN - Pointer to SNOMED TERMS (#90680.02)
; PARMS - Format var1=value_$c(28)_var2=value...
; STS - Status (A/I)
; SCO - Scope (A/C)
; PRI - Priority (L/M/H)
; PTX - Provider Text
; EDD - Definitive EDD (Date)
; NOTE - Free Text Note
;
NEW %,UID,II,DFN,VFL,FND,IEN,NOW,CONC,SNO,SNOTRM,OEDT,OEBY,RSLT,ERROR
NEW STS,SCO,PRI,PTX,EDD,NOTE,BQ,LMDT,LMBY,DIC,DLAYGO,X,Y,BJPNADD
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPUP",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPUP D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Re-assemble possible array
S PARMS=$G(PARMS,"")
I PARMS="" D
. NEW LIST,BN
. S LIST="",BN=""
. F S BN=$O(PARMS(BN)) Q:BN="" S LIST=LIST_PARMS(BN)
. K PARMS
. S PARMS=LIST
. K LIST
;
;Define variables
F BQ=1:1:$L(PARMS,$C(28)) D
. NEW PDATA,NAME,VALUE
. S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
. S NAME=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99)
. I VALUE="" S VALUE="@"
. S @NAME=VALUE
;
;Define Header
S @DATA@(II)="T00005RESULT^I00010PIPIEN^T00150ERROR_MESSAGE"_$C(30)
;
;Input validation
I $G(VIEN)="" S II=II+1,@DATA@(II)="-1^^MISSING VISIT NUMBER"_$C(30) G XADD
I $G(PRIEN)="" S II=II+1,@DATA@(II)="-1^^MISSING PROBLEM IEN"_$C(30) G XADD
;
;Get DFN
S DFN=$$GET1^DIQ(9000010,VIEN_",",".05","I")
S VFL("DFN")=DFN
S VFL("VIEN")=VIEN
;
;Check for Duplicate Entry
S FND=0,IEN="" F S IEN=$O(^BJPNPL("AC",DFN,PRIEN,IEN)) Q:IEN="" D
. ;
. ;Skip Deletes
. Q:($$GET1^DIQ(90680.01,IEN_",","2.01","I")]"")
. S FND=1
I FND=1 S II=II+1,@DATA@(II)="-1^^PATIENT ALREADY HAS PROBLEM IN THEIR PIP"_$C(30) G XADD
;
;Get current date/time
D NOW^%DTC S NOW=%
;
;Technical Note
S VFL("TNOTE")="Added Problem To PIP"
;
;Pointer to 90680.02
S CONC=$$GET1^DIQ(90680.02,PRIEN_",",".01","E")
S VFL("CONC")=CONC
;
;Add new entry
S DIC="^BJPNPL("
S DLAYGO=90680.01,DIC("P")=DLAYGO,DIC(0)="LOX"
S X=CONC
K DO,DD D FILE^DICN
I Y=-1 S II=II+1,@DATA@(II)="-1^^ADD PROBLEM PROCESS FAILED"_$C(30) G XADD
S PIPIEN=+Y
;
;Save remaining fields
S BJPNADD(90680.01,PIPIEN_",",.02)=DFN
;
;Snomed Term
S SNO=PRIEN
S VFL("TNOTE",".12")=""
S VFL("SNO")=SNO
S SNOTRM=$$GET1^DIQ(90680.02,PRIEN_",",".02","E")
S BJPNADD(90680.01,PIPIEN_",",.03)=SNO
;
;Priority
I '$D(PRI) S PRI=""
S VFL("PRIORITY")=PRI
I PRI]"" S VFL("TNOTE",.06)=""
S BJPNADD(90680.01,PIPIEN_",",.06)=PRI
;
;Scope
I '$D(SCO) S SCO="C"
S VFL("SCOPE")=SCO
S VFL("TNOTE",.08)=""
S BJPNADD(90680.01,PIPIEN_",",.07)=SCO
;
;Status
I '$D(STS) S STS="A"
S VFL("STATUS")=STS
S VFL("TNOTE",.09)=""
S BJPNADD(90680.01,PIPIEN_",",.08)=STS
;
;Definitive EDD
I '$D(EDD) S EDD=$$GET1^DIQ(9000017,DFN_",",1311,"I") I 1
E I EDD]"" S EDD=$$DATE^BJPNPRUT(EDD)
S VFL("DEDD")=EDD
S VFL("TNOTE",.1)=""
S BJPNADD(90680.01,PIPIEN_",",.09)=EDD
;
;Original Entered Date/Time
S OEDT=NOW
S VFL("OEDT")=OEDT
S VFL("TNOTE",1216)=""
S BJPNADD(90680.01,PIPIEN_",",1.01)=OEDT
;
;Original Entered By
S OEBY=DUZ
S VFL("OEBY")=OEBY
S VFL("TNOTE",1217)=""
S BJPNADD(90680.01,PIPIEN_",",1.02)=OEBY
;
;Last Modified Date
S LMDT=NOW
S VFL("LMDT")=LMDT
S BJPNADD(90680.01,PIPIEN_",",1.03)=LMDT
;
;Last Modified By
S LMBY=DUZ
S VFL("LMBY")=LMBY
S BJPNADD(90680.01,PIPIEN_",",1.04)=LMBY
;
;Provider text
I $G(PTX)]"" D
. NEW DIC,DLAYGO,X,Y
. S VFL("TNOTE",.07)=""
. S VFL("TNOTE",.11)=""
. S DIC(0)="LX",DIC="^AUTNPOV(",DLAYGO=9999999.27,X=PTX
. D ^DIC
. S PTX=+Y S:PTX=-1 PTX=""
. S BJPNADD(90680.01,PIPIEN_",",.05)=PTX
. S VFL("PTEXT")=PTX
;
;Current Note
I $G(NOTE)]"" D
. S BJPNADD(90680.01,PIPIEN_",",3)=NOTE
. S VFL("NOTE")=NOTE
. S VFL("TNOTE",2100)=""
;
;Add fields
I $D(BJPNADD) D FILE^DIE("","BJPNADD","ERROR")
I $D(ERROR) S II=II+1,@DATA@(II)="-1^^ADD PROBLEM PROCESS FAILED"_$C(30) G XADD
;
;Log V OB entry
S RSLT=$$VFILE^BJPNVFIL(PIPIEN,.VFL) I +RSLT="-1" S II=II+1,@DATA@(II)="-1^^V OB SAVE FAILED"
;
;Update frequency - Master_List
D UFREQ^BJPNPRUT(PRIEN,"")
;
S II=II+1,@DATA@(II)="1^"_PIPIEN_"^"_$C(30)
XADD S II=II+1,@DATA@(II)=$C(31)
Q
;
SNOTE(DATA,PIPIEN,VFIEN,NOTE) ;EP - BJPN SET PROBLEM NOTE
;
;This RPC sets a note into the current note field and updates the V OB entry
;
;Input:
; PIPIEN - Pointer to Prenatal Problem File
; VFIEN - Pointer to V OB entry
; NOTE - New note
;
NEW UID,II,VNIEN,NUPD,ERROR
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPRL",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPUP D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define Header
S @DATA@(II)="T00005RESULT^I00010NTIEN^T00150ERROR_MESSAGE"_$C(30)
;
;Input verification
I $G(PIPIEN)="" S II=II+1,@DATA@(II)="-1^^PIPIEN is blank"_$C(30) G XSNOTE
I $G(VFIEN)="" S II=II+1,@DATA@(II)="-1^^VFIEN is blank"_$C(30) G XSNOTE
I $G(NOTE)="" S II=II+1,@DATA@(II)="-1^^NOTE is blank"_$C(30) G XSNOTE
;
;File note
S VNIEN=$$ANOTE^BJPNPRUT(VFIEN,NOTE) I VNIEN=-1 Q "-1^^V OB NOTE SAVE FAILED"
;
;Auditing
I $G(VNIEN)]"" D
. NEW VFL
. S VFL("TNOTE",2100)=VNIEN
. D TNOTE^BJPNVFIL(VFIEN,.VFL)
;
;File current note
S NUPD(90680.01,PIPIEN_",",3)=NOTE
D FILE^DIE("","NUPD","ERROR")
I $D(ERROR) Q "-1^^CURRENT NOTE FILE FAILED"
;
S II=II+1,@DATA@(II)="1^"_VNIEN_"^"_$C(30)
;
XSNOTE S II=II+1,@DATA@(II)=$C(31)
Q
;
DEL(DATA,VIEN,VFIEN,VNIEN,DCODE,DRSN) ;BJPN DELETE PRB NOTE
;
;Delete note from V OB file
;
;Input:
; VIEN - Visit IEN
; VFIEN - V OB IEN
; VNIEN - V OB Note IEN
; DCODE - Delete Code
; DRSN - Delete Reason
;
NEW UID,II,%,NOW,NDEL,ERROR,RSLT,ENT,DFN,VFL
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPUP",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPUP D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
S @DATA@(II)="T00010RESULT^T00150ERROR_MESSAGE"_$C(30)
;
;Input validation
I $G(VIEN)="" S II=II+1,@DATA@(II)="-1^MISSING VISIT IEN"_$C(30) G XDEL
I $G(VFIEN)="" S II=II+1,@DATA@(II)="-1^MISSING VFIEN"_$C(30) G XDEL
I $G(VNIEN)="" S II=II+1,@DATA@(II)="-1^MISSING VNIEN"_$C(30) G XDEL
I $$GET1^DIQ(9000010.43,VFIEN_",",".01","I")="" S II=II+1,@DATA@(II)="-1^INVALID VFIEN"_$C(30) G XDEL
S DCODE=$G(DCODE,""),DRSN=$G(DRSN,"")
;
D NOW^%DTC
S NOW=%
;
;Technical Note
S VFL("TNOTE")="Problem Note Deleted"
;
;Mark the note as deleted
S DA(1)=VFIEN,DA=VNIEN,IENS=$$IENS^DILF(.DA)
S NDEL(9000010.431,IENS,2.01)=DUZ
S NDEL(9000010.431,IENS,2.02)=NOW
S NDEL(9000010.431,IENS,2.03)=DCODE
S NDEL(9000010.431,IENS,2.04)=DRSN
D FILE^DIE("","NDEL","ERROR")
I $D(ERROR) S II=II+1,@DATA@(II)="-1^NOTE DELETION FAILED"_$C(30) G XDEL
;
;Update Current Note (in case latest was deleted)
;
S PIPIEN=$$GET1^DIQ(9000010.43,VFIEN_",",.01,"I")
S DFN=$$GET1^DIQ(90680.01,PIPIEN_",",.02,"I")
;
;Get latest note
D NOTES^BJPNPRL("",DFN,PIPIEN,1)
S RSLT=1,ENT=$G(^TMP("BJPNPRL",$J,1))
D I RSLT=-1 G XDEL
. NEW NOTE,PIPUPD,ERROR
. I $TR(ENT,$C(31))]"" S NOTE=$P($P(ENT,U,9),$C(30))
. E S NOTE="@"
. S PIPUPD(90680.01,PIPIEN_",",3)=NOTE
. D FILE^DIE("","PIPUPD","ERROR")
. I $D(ERROR) S RSLT=-1,II=II+1,@DATA@(II)="-1^CURRENT NOTE UPDATE FAILED"_$C(30)
;
;Create V OB visit entry to record the note deletion
S VFL("DFN")=DFN
S VFL("VIEN")=VIEN
S VFL("PRIORITY")=$$GET1^DIQ(90680.01,PIPIEN_",",.06,"I") ;Priority
S VFL("SCOPE")=$$GET1^DIQ(90680.01,PIPIEN_",",.07,"I") ;Scope
S VFL("PTEXT")=$$GET1^DIQ(90680.01,PIPIEN_",",.05,"I") ;Provider Text
S VFL("STATUS")=$$GET1^DIQ(90680.01,PIPIEN_",",.08,"I") ;Status
S VFL("DEDD")=$$GET1^DIQ(90680.01,PIPIEN_",",.09,"I") ;Definitive EDD
S VFL("OEDT")=$$GET1^DIQ(90680.01,PIPIEN_",",1.01,"I") ;OEDT
S VFL("OEBY")=$$GET1^DIQ(90680.01,PIPIEN_",",1.02,"I") ;OEBY
S VFL("LMDT")=NOW
S VFL("LMBY")=DUZ
S VFL("TNOTE",1218)=""
S VFL("TNOTE",1219)=""
S VFL("TNOTE",2100)=VFIEN_":"_VNIEN_":D"
;
;Log V OB entry
S RSLT=$$VFILE^BJPNVFIL(PIPIEN,.VFL) I +RSLT="-1" S II=II+1,@DATA@(II)="-1^V OB SAVE FAILED"
;
S II=II+1,@DATA@(II)="1^"_$C(30)
;
XDEL S II=II+1,@DATA@(II)=$C(31)
Q
;
POV(DATA,VIEN,PIPIEN) ;BJPN SET AS POV
;
;Set problem as POV for visit
;
;Input:
; VIEN - Visit IEN
; PIPIEN - Pointer to Prenatal Problem
;
NEW UID,II,RET,PNARR,PTEXT,IN,PKIEN,DFN,PPRV,ICD,ICDINT,ICIEN,VFL,BJPNUPD,ERROR
NEW NOW,%,CONC,SNO,LMDT,LMBY,PTEXT,RSLT
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPUP",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPUP D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
S @DATA@(II)="T00010RESULT^T00150ERROR_MESSAGE"_$C(30)
;
;Input validation
I $G(VIEN)="" S II=II+1,@DATA@(II)="-1^MISSING VIEN"_$C(30) G XPOV
I $G(PIPIEN)="" S II=II+1,@DATA@(II)="-1^MISSING PIPIEN"_$C(30) G XPOV
;
;Get current date/time
D NOW^%DTC S NOW=%
;
;Get DFN
S DFN=$$GET1^DIQ(9000010,VIEN_",",".05","I")
S VFL("DFN")=DFN
S VFL("VIEN")=VIEN
;
;Get pointer to SNOMED file
S PKIEN=$$GET1^DIQ(90680.01,PIPIEN_",",.03,"I")
;
;Pointer to 90680.02
S CONC=$$GET1^DIQ(90680.02,PKIEN_",",".01","E")
S VFL("CONC")=CONC
;
;Snomed Term
S SNO=PKIEN
S VFL("SNO")=SNO
;
;Priority
S VFL("PRIORITY")=$$GET1^DIQ(90680.01,PIPIEN_",",.06,"I")
;
;Scope
S VFL("SCOPE")=$$GET1^DIQ(90680.01,PIPIEN_",",.07,"I")
;
;Status
S VFL("STATUS")=$$GET1^DIQ(90680.01,PIPIEN_",",.08,"I")
;
;Definitive EDD
S VFL("DEDD")=$$GET1^DIQ(90680.01,PIPIEN_",",.09,"I")
;
;Original Entered Date/Time
;S VFL("OEDT")=$$GET1^DIQ(90680.01,PIPIEN_",",1.01,"I")
;
;Original Entered By
;S VFL("OEBY")=$$GET1^DIQ(90680.01,PIPIEN_",",1.02,"I")
;
;Last Modified Date
S LMDT=NOW
S VFL("LMDT")=LMDT
S VFL("TNOTE",1218)=""
S BJPNUPD(90680.01,PIPIEN_",",1.03)=LMDT
;
;Last Modified By
S LMBY=DUZ
S VFL("LMBY")=LMBY
S VFL("TNOTE",1219)=""
S BJPNUPD(90680.01,PIPIEN_",",1.04)=LMBY
;
;Get Primary Provider
S PPRV=$$PPRV^BJPNPKL(VIEN)
;
;Set as POV
S VFL("POV")=1
S VFL("TNOTE",.05)=""
;
;Technical Note
S VFL("TNOTE")="Set Problem As POV For Visit"
;
;Assemble ICD9 List
S (ICD,ICDINT)=""
S ICIEN=0 F S ICIEN=$O(^BJPN(90680.02,PKIEN,1,ICIEN)) Q:'ICIEN D
. ;
. NEW ICD9,ICDTP,DA,IENS
. S DA(1)=PKIEN,DA=ICIEN,IENS=$$IENS^DILF(.DA)
. S ICD9=$$GET1^DIQ(90680.21,IENS,.01,"I") Q:ICD9=""
. S ICDTP=$$GET1^DIQ(90680.21,IENS,.02,"I") I ICDTP'=1 Q
. S ICD=ICD_$S(ICD]"":";",1:"")_ICD9
;
;Check for .9999
I $TR(ICD,";")="" D
. NEW DIC,X,Y
. S DIC="^ICD9(",DIC(0)="XMO",X=".9999" D ^DIC I +Y<0 Q
. S ICD=+Y
;
;Assemble Provider Narrative
S PTEXT=$$GET1^DIQ(90680.01,PIPIEN_",",.05,"E")
S PNARR=$$GET1^DIQ(90680.01,PIPIEN_",",.03,"I")
S PNARR=$$GET1^DIQ(90680.02,PNARR_",",.02,"E")
S PNARR=PNARR_"| "_PTEXT
;
;Loop through by ICD9 code
I $TR(ICD,";")]"" D
. NEW ICD9,IX
. F IX=1:1:$L(ICD,";") S ICD9=$P(ICD,";",IX) I ICD9]"" D
.. NEW IN
.. ;
.. ;
.. S IN=U_VIEN_U_"`"_ICD9_U_DFN_U_PNARR
.. S $P(IN,U,15)=PPRV
.. ;
.. ;File each POV
.. D SET^BGOVPOV(.RET,IN)
.. I +RET<0 S II=II+1,@DATA@(II)="-1^"_$P(RET,U,2)_$C(30) Q
.. S II=II+1,@DATA@(II)="1^"_$C(30)
;
;Provider Text
S PTEXT=$$GET1^DIQ(90680.01,PIPIEN_",",.05,"I")
S VFL("PTEXT")=PTEXT
;
;Update fields
I $D(BJPNUPD) D FILE^DIE("","BJPNUPD","ERROR")
I $D(ERROR) S II=II+1,@DATA@(II)="-1^SET AS POV PROCESS FAILED"_$C(30) G XPOV
;
;Log V OB entry
S RSLT=$$VFILE^BJPNVFIL(PIPIEN,.VFL) I +RSLT="-1" S II=II+1,@DATA@(II)="-1^V OB SAVE FAILED"
;
XPOV S II=II+1,@DATA@(II)=$C(31)
Q
;
VPOV(VIEN,PIPIEN) ;EP - Return whether problem is POV for visit
;
I $G(VIEN)="" Q ""
I $G(PIPIEN)="" Q ""
;
NEW POV,PKIEN,ICIEN,ICD
;
;Pull Pick List entry
S PKIEN=$$GET1^DIQ(90680.01,PIPIEN_",",.03,"I") I PKIEN="" Q ""
;
;Pull the ICD-9(s)
S ICIEN=0 F S ICIEN=$O(^BJPN(90680.02,PKIEN,1,ICIEN)) Q:'ICIEN D
. ;
. NEW ICD9,ICDTP,DA,IENS
. S DA(1)=PKIEN,DA=ICIEN,IENS=$$IENS^DILF(.DA)
. S ICD9=$$GET1^DIQ(90680.21,IENS,.01,"I") Q:ICD9=""
. S ICDTP=$$GET1^DIQ(90680.21,IENS,.02,"I") I ICDTP'=1 Q
. S ICD(ICD9)=$$GET1^DIQ(90680.21,IENS,.01,"E")
;
;Check for .9999
I '$D(ICD) D
. NEW DIC,X,Y
. S DIC="^ICD9(",DIC(0)="XMO",X=".9999" D ^DIC I +Y<0 Q
. S ICD(+Y)=".9999"
;
S POV=""
S ICIEN="" F S ICIEN=$O(^AUPNVPOV("AD",VIEN,ICIEN)) Q:ICIEN="" D Q:POV="Y"
. NEW ICDCD,VPNARR,SNOMED
. S VPNARR=$P($$GET1^DIQ(9000010.07,ICIEN_",",.04,"E"),"|")
. S SNOMED=$$GET1^DIQ(90680.01,PIPIEN_",",.03,"I") Q:SNOMED=""
. S SNOMED=$$GET1^DIQ(90680.02,SNOMED_",",.02,"E") Q:SNOMED=""
. ;
. S ICDCD=$$GET1^DIQ(9000010.07,ICIEN_",",.01,"I") Q:ICDCD=""
. I $D(ICD(ICDCD)),SNOMED=VPNARR S POV="Y" Q
. Q
;
Q POV
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S II=$G(II)+1,@DATA@(II)=$C(31)
Q
BJPNPUP ;GDIT/HS/BEE-Prenatal Care Module Problem Handling Code ; 08 May 2012 12:00 PM
+1 ;;2.0;PRENATAL CARE MODULE;;Feb 24, 2015;Build 63
+2 ;
+3 QUIT
+4 ;
ADD(DATA,VIEN,PRIEN,PARMS) ;EP - BJPN SET PRB FROM PIP
+1 ;
+2 ;Input:
+3 ; VIEN - Visit IEN
+4 ; PRIEN - Pointer to SNOMED TERMS (#90680.02)
+5 ; PARMS - Format var1=value_$c(28)_var2=value...
+6 ; STS - Status (A/I)
+7 ; SCO - Scope (A/C)
+8 ; PRI - Priority (L/M/H)
+9 ; PTX - Provider Text
+10 ; EDD - Definitive EDD (Date)
+11 ; NOTE - Free Text Note
+12 ;
+13 NEW %,UID,II,DFN,VFL,FND,IEN,NOW,CONC,SNO,SNOTRM,OEDT,OEBY,RSLT,ERROR
+14 NEW STS,SCO,PRI,PTX,EDD,NOTE,BQ,LMDT,LMBY,DIC,DLAYGO,X,Y,BJPNADD
+15 ;
+16 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+17 SET DATA=$NAME(^TMP("BJPNPUP",UID))
+18 KILL @DATA
+19 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+20 ;
+21 SET II=0
+22 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPUP D UNWIND^%ZTER"
+23 ;
+24 ;Re-assemble possible array
+25 SET PARMS=$GET(PARMS,"")
+26 IF PARMS=""
Begin DoDot:1
+27 NEW LIST,BN
+28 SET LIST=""
SET BN=""
+29 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+30 KILL PARMS
+31 SET PARMS=LIST
+32 KILL LIST
End DoDot:1
+33 ;
+34 ;Define variables
+35 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+36 NEW PDATA,NAME,VALUE
+37 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+38 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+39 IF VALUE=""
SET VALUE="@"
+40 SET @NAME=VALUE
End DoDot:1
+41 ;
+42 ;Define Header
+43 SET @DATA@(II)="T00005RESULT^I00010PIPIEN^T00150ERROR_MESSAGE"_$CHAR(30)
+44 ;
+45 ;Input validation
+46 IF $GET(VIEN)=""
SET II=II+1
SET @DATA@(II)="-1^^MISSING VISIT NUMBER"_$CHAR(30)
GOTO XADD
+47 IF $GET(PRIEN)=""
SET II=II+1
SET @DATA@(II)="-1^^MISSING PROBLEM IEN"_$CHAR(30)
GOTO XADD
+48 ;
+49 ;Get DFN
+50 SET DFN=$$GET1^DIQ(9000010,VIEN_",",".05","I")
+51 SET VFL("DFN")=DFN
+52 SET VFL("VIEN")=VIEN
+53 ;
+54 ;Check for Duplicate Entry
+55 SET FND=0
SET IEN=""
FOR
SET IEN=$ORDER(^BJPNPL("AC",DFN,PRIEN,IEN))
IF IEN=""
QUIT
Begin DoDot:1
+56 ;
+57 ;Skip Deletes
+58 IF ($$GET1^DIQ(90680.01,IEN_",","2.01","I")]"")
QUIT
+59 SET FND=1
End DoDot:1
+60 IF FND=1
SET II=II+1
SET @DATA@(II)="-1^^PATIENT ALREADY HAS PROBLEM IN THEIR PIP"_$CHAR(30)
GOTO XADD
+61 ;
+62 ;Get current date/time
+63 DO NOW^%DTC
SET NOW=%
+64 ;
+65 ;Technical Note
+66 SET VFL("TNOTE")="Added Problem To PIP"
+67 ;
+68 ;Pointer to 90680.02
+69 SET CONC=$$GET1^DIQ(90680.02,PRIEN_",",".01","E")
+70 SET VFL("CONC")=CONC
+71 ;
+72 ;Add new entry
+73 SET DIC="^BJPNPL("
+74 SET DLAYGO=90680.01
SET DIC("P")=DLAYGO
SET DIC(0)="LOX"
+75 SET X=CONC
+76 KILL DO,DD
DO FILE^DICN
+77 IF Y=-1
SET II=II+1
SET @DATA@(II)="-1^^ADD PROBLEM PROCESS FAILED"_$CHAR(30)
GOTO XADD
+78 SET PIPIEN=+Y
+79 ;
+80 ;Save remaining fields
+81 SET BJPNADD(90680.01,PIPIEN_",",.02)=DFN
+82 ;
+83 ;Snomed Term
+84 SET SNO=PRIEN
+85 SET VFL("TNOTE",".12")=""
+86 SET VFL("SNO")=SNO
+87 SET SNOTRM=$$GET1^DIQ(90680.02,PRIEN_",",".02","E")
+88 SET BJPNADD(90680.01,PIPIEN_",",.03)=SNO
+89 ;
+90 ;Priority
+91 IF '$DATA(PRI)
SET PRI=""
+92 SET VFL("PRIORITY")=PRI
+93 IF PRI]""
SET VFL("TNOTE",.06)=""
+94 SET BJPNADD(90680.01,PIPIEN_",",.06)=PRI
+95 ;
+96 ;Scope
+97 IF '$DATA(SCO)
SET SCO="C"
+98 SET VFL("SCOPE")=SCO
+99 SET VFL("TNOTE",.08)=""
+100 SET BJPNADD(90680.01,PIPIEN_",",.07)=SCO
+101 ;
+102 ;Status
+103 IF '$DATA(STS)
SET STS="A"
+104 SET VFL("STATUS")=STS
+105 SET VFL("TNOTE",.09)=""
+106 SET BJPNADD(90680.01,PIPIEN_",",.08)=STS
+107 ;
+108 ;Definitive EDD
+109 IF '$DATA(EDD)
SET EDD=$$GET1^DIQ(9000017,DFN_",",1311,"I")
IF 1
+110 IF '$TEST
IF EDD]""
SET EDD=$$DATE^BJPNPRUT(EDD)
+111 SET VFL("DEDD")=EDD
+112 SET VFL("TNOTE",.1)=""
+113 SET BJPNADD(90680.01,PIPIEN_",",.09)=EDD
+114 ;
+115 ;Original Entered Date/Time
+116 SET OEDT=NOW
+117 SET VFL("OEDT")=OEDT
+118 SET VFL("TNOTE",1216)=""
+119 SET BJPNADD(90680.01,PIPIEN_",",1.01)=OEDT
+120 ;
+121 ;Original Entered By
+122 SET OEBY=DUZ
+123 SET VFL("OEBY")=OEBY
+124 SET VFL("TNOTE",1217)=""
+125 SET BJPNADD(90680.01,PIPIEN_",",1.02)=OEBY
+126 ;
+127 ;Last Modified Date
+128 SET LMDT=NOW
+129 SET VFL("LMDT")=LMDT
+130 SET BJPNADD(90680.01,PIPIEN_",",1.03)=LMDT
+131 ;
+132 ;Last Modified By
+133 SET LMBY=DUZ
+134 SET VFL("LMBY")=LMBY
+135 SET BJPNADD(90680.01,PIPIEN_",",1.04)=LMBY
+136 ;
+137 ;Provider text
+138 IF $GET(PTX)]""
Begin DoDot:1
+139 NEW DIC,DLAYGO,X,Y
+140 SET VFL("TNOTE",.07)=""
+141 SET VFL("TNOTE",.11)=""
+142 SET DIC(0)="LX"
SET DIC="^AUTNPOV("
SET DLAYGO=9999999.27
SET X=PTX
+143 DO ^DIC
+144 SET PTX=+Y
IF PTX=-1
SET PTX=""
+145 SET BJPNADD(90680.01,PIPIEN_",",.05)=PTX
+146 SET VFL("PTEXT")=PTX
End DoDot:1
+147 ;
+148 ;Current Note
+149 IF $GET(NOTE)]""
Begin DoDot:1
+150 SET BJPNADD(90680.01,PIPIEN_",",3)=NOTE
+151 SET VFL("NOTE")=NOTE
+152 SET VFL("TNOTE",2100)=""
End DoDot:1
+153 ;
+154 ;Add fields
+155 IF $DATA(BJPNADD)
DO FILE^DIE("","BJPNADD","ERROR")
+156 IF $DATA(ERROR)
SET II=II+1
SET @DATA@(II)="-1^^ADD PROBLEM PROCESS FAILED"_$CHAR(30)
GOTO XADD
+157 ;
+158 ;Log V OB entry
+159 SET RSLT=$$VFILE^BJPNVFIL(PIPIEN,.VFL)
IF +RSLT="-1"
SET II=II+1
SET @DATA@(II)="-1^^V OB SAVE FAILED"
+160 ;
+161 ;Update frequency - Master_List
+162 DO UFREQ^BJPNPRUT(PRIEN,"")
+163 ;
+164 SET II=II+1
SET @DATA@(II)="1^"_PIPIEN_"^"_$CHAR(30)
XADD SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
SNOTE(DATA,PIPIEN,VFIEN,NOTE) ;EP - BJPN SET PROBLEM NOTE
+1 ;
+2 ;This RPC sets a note into the current note field and updates the V OB entry
+3 ;
+4 ;Input:
+5 ; PIPIEN - Pointer to Prenatal Problem File
+6 ; VFIEN - Pointer to V OB entry
+7 ; NOTE - New note
+8 ;
+9 NEW UID,II,VNIEN,NUPD,ERROR
+10 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+11 SET DATA=$NAME(^TMP("BJPNPRL",UID))
+12 KILL @DATA
+13 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+14 ;
+15 SET II=0
+16 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPUP D UNWIND^%ZTER"
+17 ;
+18 ;Define Header
+19 SET @DATA@(II)="T00005RESULT^I00010NTIEN^T00150ERROR_MESSAGE"_$CHAR(30)
+20 ;
+21 ;Input verification
+22 IF $GET(PIPIEN)=""
SET II=II+1
SET @DATA@(II)="-1^^PIPIEN is blank"_$CHAR(30)
GOTO XSNOTE
+23 IF $GET(VFIEN)=""
SET II=II+1
SET @DATA@(II)="-1^^VFIEN is blank"_$CHAR(30)
GOTO XSNOTE
+24 IF $GET(NOTE)=""
SET II=II+1
SET @DATA@(II)="-1^^NOTE is blank"_$CHAR(30)
GOTO XSNOTE
+25 ;
+26 ;File note
+27 SET VNIEN=$$ANOTE^BJPNPRUT(VFIEN,NOTE)
IF VNIEN=-1
QUIT "-1^^V OB NOTE SAVE FAILED"
+28 ;
+29 ;Auditing
+30 IF $GET(VNIEN)]""
Begin DoDot:1
+31 NEW VFL
+32 SET VFL("TNOTE",2100)=VNIEN
+33 DO TNOTE^BJPNVFIL(VFIEN,.VFL)
End DoDot:1
+34 ;
+35 ;File current note
+36 SET NUPD(90680.01,PIPIEN_",",3)=NOTE
+37 DO FILE^DIE("","NUPD","ERROR")
+38 IF $DATA(ERROR)
QUIT "-1^^CURRENT NOTE FILE FAILED"
+39 ;
+40 SET II=II+1
SET @DATA@(II)="1^"_VNIEN_"^"_$CHAR(30)
+41 ;
XSNOTE SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
DEL(DATA,VIEN,VFIEN,VNIEN,DCODE,DRSN) ;BJPN DELETE PRB NOTE
+1 ;
+2 ;Delete note from V OB file
+3 ;
+4 ;Input:
+5 ; VIEN - Visit IEN
+6 ; VFIEN - V OB IEN
+7 ; VNIEN - V OB Note IEN
+8 ; DCODE - Delete Code
+9 ; DRSN - Delete Reason
+10 ;
+11 NEW UID,II,%,NOW,NDEL,ERROR,RSLT,ENT,DFN,VFL
+12 ;
+13 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+14 SET DATA=$NAME(^TMP("BJPNPUP",UID))
+15 KILL @DATA
+16 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+17 ;
+18 SET II=0
+19 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPUP D UNWIND^%ZTER"
+20 ;
+21 SET @DATA@(II)="T00010RESULT^T00150ERROR_MESSAGE"_$CHAR(30)
+22 ;
+23 ;Input validation
+24 IF $GET(VIEN)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING VISIT IEN"_$CHAR(30)
GOTO XDEL
+25 IF $GET(VFIEN)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING VFIEN"_$CHAR(30)
GOTO XDEL
+26 IF $GET(VNIEN)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING VNIEN"_$CHAR(30)
GOTO XDEL
+27 IF $$GET1^DIQ(9000010.43,VFIEN_",",".01","I")=""
SET II=II+1
SET @DATA@(II)="-1^INVALID VFIEN"_$CHAR(30)
GOTO XDEL
+28 SET DCODE=$GET(DCODE,"")
SET DRSN=$GET(DRSN,"")
+29 ;
+30 DO NOW^%DTC
+31 SET NOW=%
+32 ;
+33 ;Technical Note
+34 SET VFL("TNOTE")="Problem Note Deleted"
+35 ;
+36 ;Mark the note as deleted
+37 SET DA(1)=VFIEN
SET DA=VNIEN
SET IENS=$$IENS^DILF(.DA)
+38 SET NDEL(9000010.431,IENS,2.01)=DUZ
+39 SET NDEL(9000010.431,IENS,2.02)=NOW
+40 SET NDEL(9000010.431,IENS,2.03)=DCODE
+41 SET NDEL(9000010.431,IENS,2.04)=DRSN
+42 DO FILE^DIE("","NDEL","ERROR")
+43 IF $DATA(ERROR)
SET II=II+1
SET @DATA@(II)="-1^NOTE DELETION FAILED"_$CHAR(30)
GOTO XDEL
+44 ;
+45 ;Update Current Note (in case latest was deleted)
+46 ;
+47 SET PIPIEN=$$GET1^DIQ(9000010.43,VFIEN_",",.01,"I")
+48 SET DFN=$$GET1^DIQ(90680.01,PIPIEN_",",.02,"I")
+49 ;
+50 ;Get latest note
+51 DO NOTES^BJPNPRL("",DFN,PIPIEN,1)
+52 SET RSLT=1
SET ENT=$GET(^TMP("BJPNPRL",$JOB,1))
+53 Begin DoDot:1
+54 NEW NOTE,PIPUPD,ERROR
+55 IF $TRANSLATE(ENT,$CHAR(31))]""
SET NOTE=$PIECE($PIECE(ENT,U,9),$CHAR(30))
+56 IF '$TEST
SET NOTE="@"
+57 SET PIPUPD(90680.01,PIPIEN_",",3)=NOTE
+58 DO FILE^DIE("","PIPUPD","ERROR")
+59 IF $DATA(ERROR)
SET RSLT=-1
SET II=II+1
SET @DATA@(II)="-1^CURRENT NOTE UPDATE FAILED"_$CHAR(30)
End DoDot:1
IF RSLT=-1
GOTO XDEL
+60 ;
+61 ;Create V OB visit entry to record the note deletion
+62 SET VFL("DFN")=DFN
+63 SET VFL("VIEN")=VIEN
+64 ;Priority
SET VFL("PRIORITY")=$$GET1^DIQ(90680.01,PIPIEN_",",.06,"I")
+65 ;Scope
SET VFL("SCOPE")=$$GET1^DIQ(90680.01,PIPIEN_",",.07,"I")
+66 ;Provider Text
SET VFL("PTEXT")=$$GET1^DIQ(90680.01,PIPIEN_",",.05,"I")
+67 ;Status
SET VFL("STATUS")=$$GET1^DIQ(90680.01,PIPIEN_",",.08,"I")
+68 ;Definitive EDD
SET VFL("DEDD")=$$GET1^DIQ(90680.01,PIPIEN_",",.09,"I")
+69 ;OEDT
SET VFL("OEDT")=$$GET1^DIQ(90680.01,PIPIEN_",",1.01,"I")
+70 ;OEBY
SET VFL("OEBY")=$$GET1^DIQ(90680.01,PIPIEN_",",1.02,"I")
+71 SET VFL("LMDT")=NOW
+72 SET VFL("LMBY")=DUZ
+73 SET VFL("TNOTE",1218)=""
+74 SET VFL("TNOTE",1219)=""
+75 SET VFL("TNOTE",2100)=VFIEN_":"_VNIEN_":D"
+76 ;
+77 ;Log V OB entry
+78 SET RSLT=$$VFILE^BJPNVFIL(PIPIEN,.VFL)
IF +RSLT="-1"
SET II=II+1
SET @DATA@(II)="-1^V OB SAVE FAILED"
+79 ;
+80 SET II=II+1
SET @DATA@(II)="1^"_$CHAR(30)
+81 ;
XDEL SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
POV(DATA,VIEN,PIPIEN) ;BJPN SET AS POV
+1 ;
+2 ;Set problem as POV for visit
+3 ;
+4 ;Input:
+5 ; VIEN - Visit IEN
+6 ; PIPIEN - Pointer to Prenatal Problem
+7 ;
+8 NEW UID,II,RET,PNARR,PTEXT,IN,PKIEN,DFN,PPRV,ICD,ICDINT,ICIEN,VFL,BJPNUPD,ERROR
+9 NEW NOW,%,CONC,SNO,LMDT,LMBY,PTEXT,RSLT
+10 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+11 SET DATA=$NAME(^TMP("BJPNPUP",UID))
+12 KILL @DATA
+13 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+14 ;
+15 SET II=0
+16 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPUP D UNWIND^%ZTER"
+17 ;
+18 SET @DATA@(II)="T00010RESULT^T00150ERROR_MESSAGE"_$CHAR(30)
+19 ;
+20 ;Input validation
+21 IF $GET(VIEN)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING VIEN"_$CHAR(30)
GOTO XPOV
+22 IF $GET(PIPIEN)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING PIPIEN"_$CHAR(30)
GOTO XPOV
+23 ;
+24 ;Get current date/time
+25 DO NOW^%DTC
SET NOW=%
+26 ;
+27 ;Get DFN
+28 SET DFN=$$GET1^DIQ(9000010,VIEN_",",".05","I")
+29 SET VFL("DFN")=DFN
+30 SET VFL("VIEN")=VIEN
+31 ;
+32 ;Get pointer to SNOMED file
+33 SET PKIEN=$$GET1^DIQ(90680.01,PIPIEN_",",.03,"I")
+34 ;
+35 ;Pointer to 90680.02
+36 SET CONC=$$GET1^DIQ(90680.02,PKIEN_",",".01","E")
+37 SET VFL("CONC")=CONC
+38 ;
+39 ;Snomed Term
+40 SET SNO=PKIEN
+41 SET VFL("SNO")=SNO
+42 ;
+43 ;Priority
+44 SET VFL("PRIORITY")=$$GET1^DIQ(90680.01,PIPIEN_",",.06,"I")
+45 ;
+46 ;Scope
+47 SET VFL("SCOPE")=$$GET1^DIQ(90680.01,PIPIEN_",",.07,"I")
+48 ;
+49 ;Status
+50 SET VFL("STATUS")=$$GET1^DIQ(90680.01,PIPIEN_",",.08,"I")
+51 ;
+52 ;Definitive EDD
+53 SET VFL("DEDD")=$$GET1^DIQ(90680.01,PIPIEN_",",.09,"I")
+54 ;
+55 ;Original Entered Date/Time
+56 ;S VFL("OEDT")=$$GET1^DIQ(90680.01,PIPIEN_",",1.01,"I")
+57 ;
+58 ;Original Entered By
+59 ;S VFL("OEBY")=$$GET1^DIQ(90680.01,PIPIEN_",",1.02,"I")
+60 ;
+61 ;Last Modified Date
+62 SET LMDT=NOW
+63 SET VFL("LMDT")=LMDT
+64 SET VFL("TNOTE",1218)=""
+65 SET BJPNUPD(90680.01,PIPIEN_",",1.03)=LMDT
+66 ;
+67 ;Last Modified By
+68 SET LMBY=DUZ
+69 SET VFL("LMBY")=LMBY
+70 SET VFL("TNOTE",1219)=""
+71 SET BJPNUPD(90680.01,PIPIEN_",",1.04)=LMBY
+72 ;
+73 ;Get Primary Provider
+74 SET PPRV=$$PPRV^BJPNPKL(VIEN)
+75 ;
+76 ;Set as POV
+77 SET VFL("POV")=1
+78 SET VFL("TNOTE",.05)=""
+79 ;
+80 ;Technical Note
+81 SET VFL("TNOTE")="Set Problem As POV For Visit"
+82 ;
+83 ;Assemble ICD9 List
+84 SET (ICD,ICDINT)=""
+85 SET ICIEN=0
FOR
SET ICIEN=$ORDER(^BJPN(90680.02,PKIEN,1,ICIEN))
IF 'ICIEN
QUIT
Begin DoDot:1
+86 ;
+87 NEW ICD9,ICDTP,DA,IENS
+88 SET DA(1)=PKIEN
SET DA=ICIEN
SET IENS=$$IENS^DILF(.DA)
+89 SET ICD9=$$GET1^DIQ(90680.21,IENS,.01,"I")
IF ICD9=""
QUIT
+90 SET ICDTP=$$GET1^DIQ(90680.21,IENS,.02,"I")
IF ICDTP'=1
QUIT
+91 SET ICD=ICD_$SELECT(ICD]"":";",1:"")_ICD9
End DoDot:1
+92 ;
+93 ;Check for .9999
+94 IF $TRANSLATE(ICD,";")=""
Begin DoDot:1
+95 NEW DIC,X,Y
+96 SET DIC="^ICD9("
SET DIC(0)="XMO"
SET X=".9999"
DO ^DIC
IF +Y<0
QUIT
+97 SET ICD=+Y
End DoDot:1
+98 ;
+99 ;Assemble Provider Narrative
+100 SET PTEXT=$$GET1^DIQ(90680.01,PIPIEN_",",.05,"E")
+101 SET PNARR=$$GET1^DIQ(90680.01,PIPIEN_",",.03,"I")
+102 SET PNARR=$$GET1^DIQ(90680.02,PNARR_",",.02,"E")
+103 SET PNARR=PNARR_"| "_PTEXT
+104 ;
+105 ;Loop through by ICD9 code
+106 IF $TRANSLATE(ICD,";")]""
Begin DoDot:1
+107 NEW ICD9,IX
+108 FOR IX=1:1:$LENGTH(ICD,";")
SET ICD9=$PIECE(ICD,";",IX)
IF ICD9]""
Begin DoDot:2
+109 NEW IN
+110 ;
+111 ;
+112 SET IN=U_VIEN_U_"`"_ICD9_U_DFN_U_PNARR
+113 SET $PIECE(IN,U,15)=PPRV
+114 ;
+115 ;File each POV
+116 DO SET^BGOVPOV(.RET,IN)
+117 IF +RET<0
SET II=II+1
SET @DATA@(II)="-1^"_$PIECE(RET,U,2)_$CHAR(30)
QUIT
+118 SET II=II+1
SET @DATA@(II)="1^"_$CHAR(30)
End DoDot:2
End DoDot:1
+119 ;
+120 ;Provider Text
+121 SET PTEXT=$$GET1^DIQ(90680.01,PIPIEN_",",.05,"I")
+122 SET VFL("PTEXT")=PTEXT
+123 ;
+124 ;Update fields
+125 IF $DATA(BJPNUPD)
DO FILE^DIE("","BJPNUPD","ERROR")
+126 IF $DATA(ERROR)
SET II=II+1
SET @DATA@(II)="-1^SET AS POV PROCESS FAILED"_$CHAR(30)
GOTO XPOV
+127 ;
+128 ;Log V OB entry
+129 SET RSLT=$$VFILE^BJPNVFIL(PIPIEN,.VFL)
IF +RSLT="-1"
SET II=II+1
SET @DATA@(II)="-1^V OB SAVE FAILED"
+130 ;
XPOV SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
VPOV(VIEN,PIPIEN) ;EP - Return whether problem is POV for visit
+1 ;
+2 IF $GET(VIEN)=""
QUIT ""
+3 IF $GET(PIPIEN)=""
QUIT ""
+4 ;
+5 NEW POV,PKIEN,ICIEN,ICD
+6 ;
+7 ;Pull Pick List entry
+8 SET PKIEN=$$GET1^DIQ(90680.01,PIPIEN_",",.03,"I")
IF PKIEN=""
QUIT ""
+9 ;
+10 ;Pull the ICD-9(s)
+11 SET ICIEN=0
FOR
SET ICIEN=$ORDER(^BJPN(90680.02,PKIEN,1,ICIEN))
IF 'ICIEN
QUIT
Begin DoDot:1
+12 ;
+13 NEW ICD9,ICDTP,DA,IENS
+14 SET DA(1)=PKIEN
SET DA=ICIEN
SET IENS=$$IENS^DILF(.DA)
+15 SET ICD9=$$GET1^DIQ(90680.21,IENS,.01,"I")
IF ICD9=""
QUIT
+16 SET ICDTP=$$GET1^DIQ(90680.21,IENS,.02,"I")
IF ICDTP'=1
QUIT
+17 SET ICD(ICD9)=$$GET1^DIQ(90680.21,IENS,.01,"E")
End DoDot:1
+18 ;
+19 ;Check for .9999
+20 IF '$DATA(ICD)
Begin DoDot:1
+21 NEW DIC,X,Y
+22 SET DIC="^ICD9("
SET DIC(0)="XMO"
SET X=".9999"
DO ^DIC
IF +Y<0
QUIT
+23 SET ICD(+Y)=".9999"
End DoDot:1
+24 ;
+25 SET POV=""
+26 SET ICIEN=""
FOR
SET ICIEN=$ORDER(^AUPNVPOV("AD",VIEN,ICIEN))
IF ICIEN=""
QUIT
Begin DoDot:1
+27 NEW ICDCD,VPNARR,SNOMED
+28 SET VPNARR=$PIECE($$GET1^DIQ(9000010.07,ICIEN_",",.04,"E"),"|")
+29 SET SNOMED=$$GET1^DIQ(90680.01,PIPIEN_",",.03,"I")
IF SNOMED=""
QUIT
+30 SET SNOMED=$$GET1^DIQ(90680.02,SNOMED_",",.02,"E")
IF SNOMED=""
QUIT
+31 ;
+32 SET ICDCD=$$GET1^DIQ(9000010.07,ICIEN_",",.01,"I")
IF ICDCD=""
QUIT
+33 IF $DATA(ICD(ICDCD))
IF SNOMED=VPNARR
SET POV="Y"
QUIT
+34 QUIT
End DoDot:1
IF POV="Y"
QUIT
+35 ;
+36 QUIT POV
+37 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET II=$GET(II)+1
SET @DATA@(II)=$CHAR(31)
+5 QUIT
