BJPNPRUT ;GDIT/HS/BEE-Prenatal Care Module Problem Handling Calls ; 08 May 2012 12:00 PM
;;2.0;PRENATAL CARE MODULE;;Feb 24, 2015;Build 63
;
Q
;
DEL(DATA,VIEN,PIPIEN,DCODE,DRSN) ;BJPN DELETE PIP PROBLEM
;
;Delete prenatal problem from PIP (and remove from V OB)
;
NEW UID,II,%,NOW,PRUPD,ERROR,RSLT,DFN,PROC,DTTM,VFL,VPUPD
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPRUT",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPRUT 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(PIPIEN)="" S II=II+1,@DATA@(II)="-1^MISSING PIPIEN"_$C(30) G XDEL
I $$GET1^DIQ(90680.01,PIPIEN_",",".01","I")="" S II=II+1,@DATA@(II)="-1^INVALID PIPIEN"_$C(30) G XDEL
I $$GET1^DIQ(90680.01,PIPIEN_",",2.01,"I")]"" S II=II+1,@DATA@(II)="-1^PROBLEM ALREADY DELETED"_$C(30) G XDEL
S DCODE=$G(DCODE,""),DRSN=$G(DRSN,"")
;
;Check for latest note
I $$GET1^DIQ(90680.01,PIPIEN_",",3,"E")]"" S II=II+1,@DATA@(II)="-1^PROBLEMS WITH NOTES CANNOT BE DELETED"_$C(30) G XDEL
;
D NOW^%DTC S NOW=%
;
;Technical Note
S VFL("TNOTE")="Problem Deleted From PIP"
;
;Retrieve DFN
S DFN=$$GET1^DIQ(9000010,VIEN_",",".05","I") I DFN="" S II=II+1,@DATA@(II)="-1^INVALID VISIT"_$C(30) G XDEL
;
;Mark as deleted
S RSLT="1"
S PRUPD(90680.01,PIPIEN_",",2.01)=DUZ
S PRUPD(90680.01,PIPIEN_",",2.02)=NOW
S PRUPD(90680.01,PIPIEN_",",2.03)=DCODE
S PRUPD(90680.01,PIPIEN_",",2.04)=DRSN
;
I $D(PRUPD) D FILE^DIE("","PRUPD","ERROR")
I $D(ERROR) S RSLT="-1^DELETE FAILED",II=II+1,@DATA@(II)=RSLT_$C(30) G XDEL
;
;Mark all V PRENATAL entries as deleted
S DTTM="" F S DTTM=$O(^AUPNVOB("AE",DFN,PIPIEN,DTTM)) Q:DTTM="" D
. NEW VPIEN
. S VPIEN="" F S VPIEN=$O(^AUPNVOB("AE",DFN,PIPIEN,DTTM,VPIEN)) Q:VPIEN="" D
.. ;
.. ;Quit if already deleted
.. Q:($$GET1^DIQ(9000010.43,VPIEN_",",2.01,"I")]"")
.. ;
.. Q:$D(PROC(VPIEN))
.. S PROC(VPIEN)=""
.. ;
.. S VPUPD(9000010.43,VPIEN_",",2.01)=DUZ
.. S VPUPD(9000010.43,VPIEN_",",2.02)=NOW
.. S VPUPD(9000010.43,VPIEN_",",2.03)=DCODE
.. S VPUPD(9000010.43,VPIEN_",",2.04)=DRSN
.. I $D(VPUPD) D FILE^DIE("","VPUPD","ERROR")
.. I $D(ERROR) S RSLT="-1^V OB DELETE FAILED",II=II+1,@DATA@(II)=RSLT_$C(30)
;
;Create final V OB visit entry to record the delete
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")=NOW
S VFL("OEBY")=DUZ
S VFL("LMDT")=NOW
S VFL("LMBY")=DUZ
S VFL("DEBY")=DUZ
S VFL("DEDT")=NOW
S VFL("DECD")=DCODE
S VFL("DERN")=DRSN
S VFL("TNOTE",2.01)=""
S VFL("TNOTE",2.02)=""
I DCODE]"" S VFL("TNOTE",2.03)=""
I DRSN]"" S VFL("TNOTE",2.04)=""
S VFL("TNOTE",1218)=""
S VFL("TNOTE",1219)=""
;
;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
;
UPD(DATA,VIEN,PIPIEN,PARMS) ;EP - BJPN UPDATE PROBLEM
;
;Input:
; VIEN - Visit IEN
; PIPIEN - PIP problem IEN
; PARMS - Format var1=value_$c(28)_var2=value...
; TRM - Snomed Term(Pointer to 90680.02)
; STS - Status (A/I)
; SCO - Scope (A/C)
; PRI - Priority (L/M/H)
; PTX - Provider Text
; EDD - Definitive EDD (Date)
; NOTE - New note
;
NEW UID,II,NOW,%,BJPNUP,EDD,LMBY,LMDT,PRI,SCO,STS,PTX,SNWCT,SNWTR1,SNWTR2
NEW BQ,NOTE,VFL,TRM,FND
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPRUT",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPRUT 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
S (TRM,STS,SCO,NOTE,PRI,PTX,EDD)=""
;
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
;
S @DATA@(II)="T00005RESULT^I00010VFIEN^T00150ERROR_MESSAGE"_$C(30)
;
;Get current date/time
D NOW^%DTC S NOW=%
;
;Technical Note
S VFL("TNOTE")="Updated Problem Entry"
;
;Pull existing fields first
;
;Patient DFN/Visit IEN
S DFN=$$GET1^DIQ(90680.01,PIPIEN_",",.02,"I")
S VFL("DFN")=DFN
S VFL("VIEN")=VIEN
;
;Handle updates
;
;Make sure code isn't assigned already
I TRM]"" D I FND=1 S II=II+1,@DATA@(II)="-1^^PATIENT ALREADY HAS PROBLEM IN THEIR PIP"_$C(30) G XUPD
. ;
. NEW IEN
. ;
. ;Check for Duplicate Entry
. S FND=0,IEN="" F S IEN=$O(^BJPNPL("AC",DFN,TRM,IEN)) Q:IEN="" D
.. ;
.. ;Skip Deletes
.. Q:($$GET1^DIQ(90680.01,IEN_",","2.01","I")]"")
.. S FND=1
;
;SNOMED Concept ID
I TRM]"" S VFL("TNOTE",.12)="",SNWCT=$$GET1^DIQ(90680.02,TRM_",",.01,"I")
I TRM="" S SNWCT=$$GET1^DIQ(90680.01,PIPIEN_",",.01,"I")
S VFL("CONC")=SNWCT
S BJPNUP(90680.01,PIPIEN_",",".01")=SNWCT
;
;SNOMED Term 1
I TRM]"" S SNWTR1=TRM
I TRM="" S SNWTR1=$$GET1^DIQ(90680.01,PIPIEN_",",.03,"I")
S VFL("SNO")=SNWTR1
S BJPNUP(90680.01,PIPIEN_",",".03")=SNWTR1
;
;SNOMED Term 2
S SNWTR2=$$GET1^DIQ(90680.01,PIPIEN_",",.04,"I")
;
;Priority
I PRI]"" S VFL("TNOTE",.06)=""
I PRI="" S PRI=$$GET1^DIQ(90680.01,PIPIEN_",",.06,"I")
S VFL("PRIORITY")=PRI
S BJPNUP(90680.01,PIPIEN_",",.06)=PRI
;
;Scope
I SCO]"" S VFL("TNOTE",.08)=""
I SCO="" S SCO=$$GET1^DIQ(90680.01,PIPIEN_",",.07,"I")
S VFL("SCOPE")=SCO
S BJPNUP(90680.01,PIPIEN_",",.07)=SCO
;
;Status
I STS]"" S VFL("TNOTE",.09)=""
I STS="" S STS=$$GET1^DIQ(90680.01,PIPIEN_",",.08,"I")
S VFL("STATUS")=STS
S BJPNUP(90680.01,PIPIEN_",",.08)=STS
;
;Definitive EDD
I EDD]"" S VFL("TNOTE",.1)=""
I EDD]"" S EDD=$$DATE(EDD)
I EDD="" S EDD=$$GET1^DIQ(90680.01,PIPIEN_",",.09,"I")
S VFL("DEDD")=EDD
S BJPNUP(90680.01,PIPIEN_",",.09)=EDD
;
;Last Modified Date
S LMDT=NOW
S VFL("LMDT")=LMDT
S VFL("TNOTE",1218)=""
S BJPNUP(90680.01,PIPIEN_",",1.03)=LMDT
;
;Last Modified By
S LMBY=DUZ
S VFL("LMBY")=LMBY
S VFL("TNOTE",1219)=""
S BJPNUP(90680.01,PIPIEN_",",1.04)=LMBY
;
;Provider text
I PTX]"" D
. NEW DIC,DLAYGO,X,Y
. S VFL("TNOTE",.07)=""
. S VFL("TNOTE",.11)=""
. ;
. ;Update the V POV file entry
. D UPDPOV(VIEN,PIPIEN,PTX)
. ;
. S DIC(0)="LX",DIC="^AUTNPOV(",DLAYGO=9999999.27,X=PTX
. D ^DIC
. S PTX=+Y S:PTX=-1 PTX=""
I PTX="" S PTX=$$GET1^DIQ(90680.01,PIPIEN_",",.05,"I")
S BJPNUP(90680.01,PIPIEN_",",.05)=PTX
S VFL("PTEXT")=PTX
;
;Current Note
I $G(NOTE)]"" D
. S VFL("TNOTE",2100)=""
. S BJPNUP(90680.01,PIPIEN_",",3)=NOTE
. S VFL("NOTE")=NOTE
;
;Update entry
I $D(BJPNUP) D FILE^DIE("","BJPNUP","ERROR")
I $D(ERROR) S II=II+1,@DATA@(II)="-1^^UPDATE PROBLEM PROCESS FAILED"_$C(30) G XUPD
;
;Log V OB entry
S RSLT=$$VFILE^BJPNVFIL(PIPIEN,.VFL) I +RSLT="-1" S II=II+1,@DATA@(II)="-1^^V OB SAVE FAILED" G XUPD
S II=II+1,@DATA@(II)="1^"_RSLT_"^"_$C(30)
;
XUPD S II=II+1,@DATA@(II)=$C(31)
;
Q
;
ANOTE(VFIEN,NOTE,NEDT,NEBY) ;EP - Add note to V OB entry
;
NEW DIC,DLAYGO,X,Y,VNIEN,DA
;
I $G(VFIEN)="" Q "-1"
I $G(NOTE)="" Q "-1"
;
;Pull Modified Date/By
S:$G(NEDT)="" NEDT=$$GET1^DIQ(9000010.43,VFIEN_",",1218,"I")
S:$G(NEBY)="" NEBY=$$GET1^DIQ(9000010.43,VFIEN_",",1219,"I")
;
;Add new entry
S DIC="^AUPNVOB("_VFIEN_",21,",DA(1)=VFIEN
S DLAYGO=9000010.431,DIC("P")=DLAYGO,DIC(0)="LOX"
S X=NOTE
S DIC("DR")=".02////"_NEDT_";.03////"_NEBY
;
K DO,DD D FILE^DICN
;
XANOTE Q +Y
;
DATE(DATE) ;EP - Convert standard date/time to a FileMan date/time
;Input
; DATE - In a standard format
;Output
; -1 is if it couldn't convert to a FileMan date
; otherwise a standard FileMan date
NEW %DT,X,Y,%
I DATE[":" D
. I DATE["/",$L(DATE," ")=3 S DATE=$P(DATE," ",1)_"@"_$P(DATE," ",2)_$P(DATE," ",3) Q
. I $L(DATE," ")=3 S DATE=$P(DATE," ",1,2)_"@"_$P(DATE," ",3)
. I $L(DATE," ")>3 S DATE=$P(DATE," ",1,3)_"@"_$P(DATE," ",4,99)
S %DT="TS",X=DATE D ^%DT
I Y=-1 S Y=""
;
Q Y
;
UFREQ(PRIEN,PLIEN) ;EP - UPDATE FREQUENCY FOR ENTRY
;
;Input:
; PRIEN - Problem Pointer
; PLIEN - Pick List Pointer (Master if Null)
;
S PRIEN=$G(PRIEN) Q:PRIEN=""
S PLIEN=$G(PLIEN)
;
NEW IEN,DA,IENS,FREQ,ERROR,FRQUPD
;
;Handle Master_List Updates
S:PLIEN="" PLIEN=$O(^BJPN(90680.03,"B","Master_List",""))
Q:PLIEN=""
;
;Locate entry
S IEN=$O(^BJPN(90680.03,PLIEN,1,"AC",PRIEN,"")) Q:IEN=""
;
;Pull existing frequency count
S DA(1)=PLIEN,DA=IEN,IENS=$$IENS^DILF(.DA)
S FREQ=+$$GET1^DIQ(90680.031,IENS,".03","I")
S FREQ=FREQ+1
;
;Save updated frequency
S FRQUPD(90680.031,IENS,".03")=FREQ
D FILE^DIE("","FRQUPD","ERROR")
;
Q
;
;
CLSMBR(DATA,USER,CLASS) ;BJPN USR CLASS MEMBER
;
;Returns whether user is a member of the specified class
;
;Input:
; USER - The user to check (DUZ value)
; CLASS - The class to check in
;
NEW UID,II,MBR,ERR
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPRUT",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPRUT D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
S @DATA@(II)="I00001MEMBER^T00100ERROR_MESSAGE"_$C(30)
;
;Input validation
I $G(USER)="" S II=II+1,@DATA@(II)="0^MISSING USER"_$C(30) G XCLS
I $G(CLASS)="" S II=II+1,@DATA@(II)="0^MISSING USER CLASS"_$C(30) G XCLS
;
;Perform lookup
S MBR=$$ISA(USER,CLASS,.ERR)
;
I MBR=0 S II=II+1,@DATA@(II)="0^"_$G(ERR)_$C(30)
E S II=II+1,@DATA@(II)=MBR_$C(30)
;
XCLS S II=II+1,@DATA@(II)=$C(31)
Q
;
ISA(USER,CLASS,ERR) ; Boolean - Is USER a Member of CLASS?
NEW USRY,USRI
I $S(CLASS="USER":1,CLASS=+$O(^USR(8930,"B","USER",0)):1,1:0) S USRY=1 G ISAX
I '+USER S USER=+$O(^VA(200,"B",USER,0))
I +USER'>0 S ERR="INVALID USER" Q 0
I '+CLASS S CLASS=+$O(^USR(8930,"B",CLASS,0))
I +CLASS'>0 S ERR="INVALID USER CLASS" Q 0
; If USER is a member of CLASS return true
S USRY=0
I +$D(^USR(8930.3,"AUC",USER,CLASS)) D
. N USRMDA
. S USRMDA=0
. F S USRMDA=+$O(^USR(8930.3,"AUC",USER,CLASS,USRMDA)) Q:((+USRMDA'>0)!(USRY)) D
.. S USRY=+$$CURRENT(USRMDA)
I USRY Q USRY
; Otherwise, check to see if user is a member of any subclass of CLASS
S USRI=0
F S USRI=$O(^USR(8930,+CLASS,1,USRI)) Q:+USRI'>0!+$G(USRY) D
. NEW USRSUB S USRSUB=+$G(^USR(8930,+CLASS,1,USRI,0)) Q:+USRSUB'>0
. S USRY=$$ISA(USER,USRSUB) ; Recurs to find members of subclass
ISAX Q +$G(USRY)
;
CURRENT(MEMBER) ; Boolean - Is Membership current?
NEW USRIN,USROUT,USRY
S USRIN=+$P($G(^USR(8930.3,+MEMBER,0)),U,3)
S USROUT=+$P($G(^USR(8930.3,+MEMBER,0)),U,4)
I USRIN'>DT,$S(USROUT>0&(USROUT'<DT):1,USROUT=0:1,1:0) S USRY=1
E S USRY=0
Q USRY
;
UPDPOV(VIEN,PIPIEN,PTX) ;EP - Update the POV entry with the new provider text
;
NEW PKIEN,ICIEN,ICD,POV,DFN,CD
;
;Pull Pick List entry
S PKIEN=$$GET1^DIQ(90680.01,PIPIEN_",",.03,"I") I PKIEN="" Q
;
;Get the DFN
S DFN=$$GET1^DIQ(9000010,VIEN,.05,"I") Q:DFN=""
;
;Locate the current POV entry (entries)
;
;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
. 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=""
. ;
. ;Check for normal code match
. S ICDCD=$$GET1^DIQ(9000010.07,ICIEN_",",.01,"I") Q:ICDCD=""
. I $D(ICD(ICDCD)),SNOMED=VPNARR S POV=POV_$S(POV]"":";",1:"")_ICIEN Q
. ;
. Q
;
;Loop through current entries and replace the provider narrative
F CD=1:1:$L(POV,";") I $P(POV,";",CD)]"" D
. ;
. NEW RET,N,INP
. D GET^BGOVPOV(.RET,VIEN_U_$P(POV,";",CD))
. S N=$G(@RET@(1))
. S INP=$P(N,U)_U_$P(N,U,19)_U_"`"_$P(N,U,17)_U_DFN_U_$P($P(N,U,7),"| ")_"| "_PTX
. S $P(INP,U,6)=$P(N,U,10) ;Stage
. S $P(INP,U,7)=$$STC(9000010.07,.06,$P(N,U,8)) ;Modifier
. S $P(INP,U,8)=$$STC(9000010.07,.07,$P(N,U,12)) ;Cause
. S $P(INP,U,9)=$S($P(N,U,11)="REVISIT":2,1:1) ;Visit/Revisit
. S $P(INP,U,10)=$P($P(N,U,14),"~",2) ;E-Code
. S $P(INP,U,11)=$P($P(N,U,15),"~",2) ;Injury Place
. S $P(INP,U,12)=$S($P(N,U,16)="PRIMARY":"P",1:"S") ;Primary/Secondary
. S $P(INP,U,13)=$$FMTE^XLFDT($P(N,U,13),2) ;Injury Date
. S $P(INP,U,14)=$$FMTE^XLFDT($P(N,U,9),2) ;Date of Onset
. S $P(INP,U,16)=$P(N,U,21) ;Asthma
. D SET^BGOVPOV(.RET,INP)
;
Q
;
STC(FIL,FLD,VAL) ; EP - Find a code for a set of code value
; Input Parameters
; FIL = FileMan File Number
; FLD = FileMan Field Number
; VAL = Value
;
NEW VEDATA,VEQFL,VEVL,VALUE,I
S VEDATA=$P(^DD(FIL,FLD,0),U,3),VEQFL=0
;
F I=1:1 S VEVL=$P(VEDATA,";",I) Q:VEVL="" D Q:VEQFL
. S VALUE=$P(VEVL,":",1) I VAL=$P(VEVL,":",2) S VEQFL=1
;
Q VALUE
BJPNPRUT ;GDIT/HS/BEE-Prenatal Care Module Problem Handling Calls ; 08 May 2012 12:00 PM
+1 ;;2.0;PRENATAL CARE MODULE;;Feb 24, 2015;Build 63
+2 ;
+3 QUIT
+4 ;
DEL(DATA,VIEN,PIPIEN,DCODE,DRSN) ;BJPN DELETE PIP PROBLEM
+1 ;
+2 ;Delete prenatal problem from PIP (and remove from V OB)
+3 ;
+4 NEW UID,II,%,NOW,PRUPD,ERROR,RSLT,DFN,PROC,DTTM,VFL,VPUPD
+5 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+6 SET DATA=$NAME(^TMP("BJPNPRUT",UID))
+7 KILL @DATA
+8 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+9 ;
+10 SET II=0
+11 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPRUT D UNWIND^%ZTER"
+12 ;
+13 SET @DATA@(II)="T00010RESULT^T00150ERROR_MESSAGE"_$CHAR(30)
+14 ;
+15 ;Input validation
+16 IF $GET(VIEN)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING VISIT IEN"_$CHAR(30)
GOTO XDEL
+17 IF $GET(PIPIEN)=""
SET II=II+1
SET @DATA@(II)="-1^MISSING PIPIEN"_$CHAR(30)
GOTO XDEL
+18 IF $$GET1^DIQ(90680.01,PIPIEN_",",".01","I")=""
SET II=II+1
SET @DATA@(II)="-1^INVALID PIPIEN"_$CHAR(30)
GOTO XDEL
+19 IF $$GET1^DIQ(90680.01,PIPIEN_",",2.01,"I")]""
SET II=II+1
SET @DATA@(II)="-1^PROBLEM ALREADY DELETED"_$CHAR(30)
GOTO XDEL
+20 SET DCODE=$GET(DCODE,"")
SET DRSN=$GET(DRSN,"")
+21 ;
+22 ;Check for latest note
+23 IF $$GET1^DIQ(90680.01,PIPIEN_",",3,"E")]""
SET II=II+1
SET @DATA@(II)="-1^PROBLEMS WITH NOTES CANNOT BE DELETED"_$CHAR(30)
GOTO XDEL
+24 ;
+25 DO NOW^%DTC
SET NOW=%
+26 ;
+27 ;Technical Note
+28 SET VFL("TNOTE")="Problem Deleted From PIP"
+29 ;
+30 ;Retrieve DFN
+31 SET DFN=$$GET1^DIQ(9000010,VIEN_",",".05","I")
IF DFN=""
SET II=II+1
SET @DATA@(II)="-1^INVALID VISIT"_$CHAR(30)
GOTO XDEL
+32 ;
+33 ;Mark as deleted
+34 SET RSLT="1"
+35 SET PRUPD(90680.01,PIPIEN_",",2.01)=DUZ
+36 SET PRUPD(90680.01,PIPIEN_",",2.02)=NOW
+37 SET PRUPD(90680.01,PIPIEN_",",2.03)=DCODE
+38 SET PRUPD(90680.01,PIPIEN_",",2.04)=DRSN
+39 ;
+40 IF $DATA(PRUPD)
DO FILE^DIE("","PRUPD","ERROR")
+41 IF $DATA(ERROR)
SET RSLT="-1^DELETE FAILED"
SET II=II+1
SET @DATA@(II)=RSLT_$CHAR(30)
GOTO XDEL
+42 ;
+43 ;Mark all V PRENATAL entries as deleted
+44 SET DTTM=""
FOR
SET DTTM=$ORDER(^AUPNVOB("AE",DFN,PIPIEN,DTTM))
IF DTTM=""
QUIT
Begin DoDot:1
+45 NEW VPIEN
+46 SET VPIEN=""
FOR
SET VPIEN=$ORDER(^AUPNVOB("AE",DFN,PIPIEN,DTTM,VPIEN))
IF VPIEN=""
QUIT
Begin DoDot:2
+47 ;
+48 ;Quit if already deleted
+49 IF ($$GET1^DIQ(9000010.43,VPIEN_",",2.01,"I")]"")
QUIT
+50 ;
+51 IF $DATA(PROC(VPIEN))
QUIT
+52 SET PROC(VPIEN)=""
+53 ;
+54 SET VPUPD(9000010.43,VPIEN_",",2.01)=DUZ
+55 SET VPUPD(9000010.43,VPIEN_",",2.02)=NOW
+56 SET VPUPD(9000010.43,VPIEN_",",2.03)=DCODE
+57 SET VPUPD(9000010.43,VPIEN_",",2.04)=DRSN
+58 IF $DATA(VPUPD)
DO FILE^DIE("","VPUPD","ERROR")
+59 IF $DATA(ERROR)
SET RSLT="-1^V OB DELETE FAILED"
SET II=II+1
SET @DATA@(II)=RSLT_$CHAR(30)
End DoDot:2
End DoDot:1
+60 ;
+61 ;Create final V OB visit entry to record the delete
+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 SET VFL("OEDT")=NOW
+70 SET VFL("OEBY")=DUZ
+71 SET VFL("LMDT")=NOW
+72 SET VFL("LMBY")=DUZ
+73 SET VFL("DEBY")=DUZ
+74 SET VFL("DEDT")=NOW
+75 SET VFL("DECD")=DCODE
+76 SET VFL("DERN")=DRSN
+77 SET VFL("TNOTE",2.01)=""
+78 SET VFL("TNOTE",2.02)=""
+79 IF DCODE]""
SET VFL("TNOTE",2.03)=""
+80 IF DRSN]""
SET VFL("TNOTE",2.04)=""
+81 SET VFL("TNOTE",1218)=""
+82 SET VFL("TNOTE",1219)=""
+83 ;
+84 ;Log V OB entry
+85 SET RSLT=$$VFILE^BJPNVFIL(PIPIEN,.VFL)
IF +RSLT="-1"
SET II=II+1
SET @DATA@(II)="-1^V OB SAVE FAILED"
+86 ;
+87 SET II=II+1
SET @DATA@(II)="1^"_$CHAR(30)
+88 ;
XDEL SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
UPD(DATA,VIEN,PIPIEN,PARMS) ;EP - BJPN UPDATE PROBLEM
+1 ;
+2 ;Input:
+3 ; VIEN - Visit IEN
+4 ; PIPIEN - PIP problem IEN
+5 ; PARMS - Format var1=value_$c(28)_var2=value...
+6 ; TRM - Snomed Term(Pointer to 90680.02)
+7 ; STS - Status (A/I)
+8 ; SCO - Scope (A/C)
+9 ; PRI - Priority (L/M/H)
+10 ; PTX - Provider Text
+11 ; EDD - Definitive EDD (Date)
+12 ; NOTE - New note
+13 ;
+14 NEW UID,II,NOW,%,BJPNUP,EDD,LMBY,LMDT,PRI,SCO,STS,PTX,SNWCT,SNWTR1,SNWTR2
+15 NEW BQ,NOTE,VFL,TRM,FND
+16 ;
+17 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+18 SET DATA=$NAME(^TMP("BJPNPRUT",UID))
+19 KILL @DATA
+20 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+21 ;
+22 SET II=0
+23 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPRUT D UNWIND^%ZTER"
+24 ;
+25 ;Re-assemble possible array
+26 SET PARMS=$GET(PARMS,"")
+27 IF PARMS=""
Begin DoDot:1
+28 NEW LIST,BN
+29 SET LIST=""
SET BN=""
+30 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+31 KILL PARMS
+32 SET PARMS=LIST
+33 KILL LIST
End DoDot:1
+34 ;
+35 ;Define variables
+36 SET (TRM,STS,SCO,NOTE,PRI,PTX,EDD)=""
+37 ;
+38 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+39 NEW PDATA,NAME,VALUE
+40 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+41 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+42 IF VALUE=""
SET VALUE="@"
+43 SET @NAME=VALUE
End DoDot:1
+44 ;
+45 SET @DATA@(II)="T00005RESULT^I00010VFIEN^T00150ERROR_MESSAGE"_$CHAR(30)
+46 ;
+47 ;Get current date/time
+48 DO NOW^%DTC
SET NOW=%
+49 ;
+50 ;Technical Note
+51 SET VFL("TNOTE")="Updated Problem Entry"
+52 ;
+53 ;Pull existing fields first
+54 ;
+55 ;Patient DFN/Visit IEN
+56 SET DFN=$$GET1^DIQ(90680.01,PIPIEN_",",.02,"I")
+57 SET VFL("DFN")=DFN
+58 SET VFL("VIEN")=VIEN
+59 ;
+60 ;Handle updates
+61 ;
+62 ;Make sure code isn't assigned already
+63 IF TRM]""
Begin DoDot:1
+64 ;
+65 NEW IEN
+66 ;
+67 ;Check for Duplicate Entry
+68 SET FND=0
SET IEN=""
FOR
SET IEN=$ORDER(^BJPNPL("AC",DFN,TRM,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+69 ;
+70 ;Skip Deletes
+71 IF ($$GET1^DIQ(90680.01,IEN_",","2.01","I")]"")
QUIT
+72 SET FND=1
End DoDot:2
End DoDot:1
IF FND=1
SET II=II+1
SET @DATA@(II)="-1^^PATIENT ALREADY HAS PROBLEM IN THEIR PIP"_$CHAR(30)
GOTO XUPD
+73 ;
+74 ;SNOMED Concept ID
+75 IF TRM]""
SET VFL("TNOTE",.12)=""
SET SNWCT=$$GET1^DIQ(90680.02,TRM_",",.01,"I")
+76 IF TRM=""
SET SNWCT=$$GET1^DIQ(90680.01,PIPIEN_",",.01,"I")
+77 SET VFL("CONC")=SNWCT
+78 SET BJPNUP(90680.01,PIPIEN_",",".01")=SNWCT
+79 ;
+80 ;SNOMED Term 1
+81 IF TRM]""
SET SNWTR1=TRM
+82 IF TRM=""
SET SNWTR1=$$GET1^DIQ(90680.01,PIPIEN_",",.03,"I")
+83 SET VFL("SNO")=SNWTR1
+84 SET BJPNUP(90680.01,PIPIEN_",",".03")=SNWTR1
+85 ;
+86 ;SNOMED Term 2
+87 SET SNWTR2=$$GET1^DIQ(90680.01,PIPIEN_",",.04,"I")
+88 ;
+89 ;Priority
+90 IF PRI]""
SET VFL("TNOTE",.06)=""
+91 IF PRI=""
SET PRI=$$GET1^DIQ(90680.01,PIPIEN_",",.06,"I")
+92 SET VFL("PRIORITY")=PRI
+93 SET BJPNUP(90680.01,PIPIEN_",",.06)=PRI
+94 ;
+95 ;Scope
+96 IF SCO]""
SET VFL("TNOTE",.08)=""
+97 IF SCO=""
SET SCO=$$GET1^DIQ(90680.01,PIPIEN_",",.07,"I")
+98 SET VFL("SCOPE")=SCO
+99 SET BJPNUP(90680.01,PIPIEN_",",.07)=SCO
+100 ;
+101 ;Status
+102 IF STS]""
SET VFL("TNOTE",.09)=""
+103 IF STS=""
SET STS=$$GET1^DIQ(90680.01,PIPIEN_",",.08,"I")
+104 SET VFL("STATUS")=STS
+105 SET BJPNUP(90680.01,PIPIEN_",",.08)=STS
+106 ;
+107 ;Definitive EDD
+108 IF EDD]""
SET VFL("TNOTE",.1)=""
+109 IF EDD]""
SET EDD=$$DATE(EDD)
+110 IF EDD=""
SET EDD=$$GET1^DIQ(90680.01,PIPIEN_",",.09,"I")
+111 SET VFL("DEDD")=EDD
+112 SET BJPNUP(90680.01,PIPIEN_",",.09)=EDD
+113 ;
+114 ;Last Modified Date
+115 SET LMDT=NOW
+116 SET VFL("LMDT")=LMDT
+117 SET VFL("TNOTE",1218)=""
+118 SET BJPNUP(90680.01,PIPIEN_",",1.03)=LMDT
+119 ;
+120 ;Last Modified By
+121 SET LMBY=DUZ
+122 SET VFL("LMBY")=LMBY
+123 SET VFL("TNOTE",1219)=""
+124 SET BJPNUP(90680.01,PIPIEN_",",1.04)=LMBY
+125 ;
+126 ;Provider text
+127 IF PTX]""
Begin DoDot:1
+128 NEW DIC,DLAYGO,X,Y
+129 SET VFL("TNOTE",.07)=""
+130 SET VFL("TNOTE",.11)=""
+131 ;
+132 ;Update the V POV file entry
+133 DO UPDPOV(VIEN,PIPIEN,PTX)
+134 ;
+135 SET DIC(0)="LX"
SET DIC="^AUTNPOV("
SET DLAYGO=9999999.27
SET X=PTX
+136 DO ^DIC
+137 SET PTX=+Y
IF PTX=-1
SET PTX=""
End DoDot:1
+138 IF PTX=""
SET PTX=$$GET1^DIQ(90680.01,PIPIEN_",",.05,"I")
+139 SET BJPNUP(90680.01,PIPIEN_",",.05)=PTX
+140 SET VFL("PTEXT")=PTX
+141 ;
+142 ;Current Note
+143 IF $GET(NOTE)]""
Begin DoDot:1
+144 SET VFL("TNOTE",2100)=""
+145 SET BJPNUP(90680.01,PIPIEN_",",3)=NOTE
+146 SET VFL("NOTE")=NOTE
End DoDot:1
+147 ;
+148 ;Update entry
+149 IF $DATA(BJPNUP)
DO FILE^DIE("","BJPNUP","ERROR")
+150 IF $DATA(ERROR)
SET II=II+1
SET @DATA@(II)="-1^^UPDATE PROBLEM PROCESS FAILED"_$CHAR(30)
GOTO XUPD
+151 ;
+152 ;Log V OB entry
+153 SET RSLT=$$VFILE^BJPNVFIL(PIPIEN,.VFL)
IF +RSLT="-1"
SET II=II+1
SET @DATA@(II)="-1^^V OB SAVE FAILED"
GOTO XUPD
+154 SET II=II+1
SET @DATA@(II)="1^"_RSLT_"^"_$CHAR(30)
+155 ;
XUPD SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 ;
+2 QUIT
+3 ;
ANOTE(VFIEN,NOTE,NEDT,NEBY) ;EP - Add note to V OB entry
+1 ;
+2 NEW DIC,DLAYGO,X,Y,VNIEN,DA
+3 ;
+4 IF $GET(VFIEN)=""
QUIT "-1"
+5 IF $GET(NOTE)=""
QUIT "-1"
+6 ;
+7 ;Pull Modified Date/By
+8 IF $GET(NEDT)=""
SET NEDT=$$GET1^DIQ(9000010.43,VFIEN_",",1218,"I")
+9 IF $GET(NEBY)=""
SET NEBY=$$GET1^DIQ(9000010.43,VFIEN_",",1219,"I")
+10 ;
+11 ;Add new entry
+12 SET DIC="^AUPNVOB("_VFIEN_",21,"
SET DA(1)=VFIEN
+13 SET DLAYGO=9000010.431
SET DIC("P")=DLAYGO
SET DIC(0)="LOX"
+14 SET X=NOTE
+15 SET DIC("DR")=".02////"_NEDT_";.03////"_NEBY
+16 ;
+17 KILL DO,DD
DO FILE^DICN
+18 ;
XANOTE QUIT +Y
+1 ;
DATE(DATE) ;EP - Convert standard date/time to a FileMan date/time
+1 ;Input
+2 ; DATE - In a standard format
+3 ;Output
+4 ; -1 is if it couldn't convert to a FileMan date
+5 ; otherwise a standard FileMan date
+6 NEW %DT,X,Y,%
+7 IF DATE[":"
Begin DoDot:1
+8 IF DATE["/"
IF $LENGTH(DATE," ")=3
SET DATE=$PIECE(DATE," ",1)_"@"_$PIECE(DATE," ",2)_$PIECE(DATE," ",3)
QUIT
+9 IF $LENGTH(DATE," ")=3
SET DATE=$PIECE(DATE," ",1,2)_"@"_$PIECE(DATE," ",3)
+10 IF $LENGTH(DATE," ")>3
SET DATE=$PIECE(DATE," ",1,3)_"@"_$PIECE(DATE," ",4,99)
End DoDot:1
+11 SET %DT="TS"
SET X=DATE
DO ^%DT
+12 IF Y=-1
SET Y=""
+13 ;
+14 QUIT Y
+15 ;
UFREQ(PRIEN,PLIEN) ;EP - UPDATE FREQUENCY FOR ENTRY
+1 ;
+2 ;Input:
+3 ; PRIEN - Problem Pointer
+4 ; PLIEN - Pick List Pointer (Master if Null)
+5 ;
+6 SET PRIEN=$GET(PRIEN)
IF PRIEN=""
QUIT
+7 SET PLIEN=$GET(PLIEN)
+8 ;
+9 NEW IEN,DA,IENS,FREQ,ERROR,FRQUPD
+10 ;
+11 ;Handle Master_List Updates
+12 IF PLIEN=""
SET PLIEN=$ORDER(^BJPN(90680.03,"B","Master_List",""))
+13 IF PLIEN=""
QUIT
+14 ;
+15 ;Locate entry
+16 SET IEN=$ORDER(^BJPN(90680.03,PLIEN,1,"AC",PRIEN,""))
IF IEN=""
QUIT
+17 ;
+18 ;Pull existing frequency count
+19 SET DA(1)=PLIEN
SET DA=IEN
SET IENS=$$IENS^DILF(.DA)
+20 SET FREQ=+$$GET1^DIQ(90680.031,IENS,".03","I")
+21 SET FREQ=FREQ+1
+22 ;
+23 ;Save updated frequency
+24 SET FRQUPD(90680.031,IENS,".03")=FREQ
+25 DO FILE^DIE("","FRQUPD","ERROR")
+26 ;
+27 QUIT
+28 ;
+29 ;
CLSMBR(DATA,USER,CLASS) ;BJPN USR CLASS MEMBER
+1 ;
+2 ;Returns whether user is a member of the specified class
+3 ;
+4 ;Input:
+5 ; USER - The user to check (DUZ value)
+6 ; CLASS - The class to check in
+7 ;
+8 NEW UID,II,MBR,ERR
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+10 SET DATA=$NAME(^TMP("BJPNPRUT",UID))
+11 KILL @DATA
+12 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+13 ;
+14 SET II=0
+15 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNPRUT D UNWIND^%ZTER"
+16 ;
+17 SET @DATA@(II)="I00001MEMBER^T00100ERROR_MESSAGE"_$CHAR(30)
+18 ;
+19 ;Input validation
+20 IF $GET(USER)=""
SET II=II+1
SET @DATA@(II)="0^MISSING USER"_$CHAR(30)
GOTO XCLS
+21 IF $GET(CLASS)=""
SET II=II+1
SET @DATA@(II)="0^MISSING USER CLASS"_$CHAR(30)
GOTO XCLS
+22 ;
+23 ;Perform lookup
+24 SET MBR=$$ISA(USER,CLASS,.ERR)
+25 ;
+26 IF MBR=0
SET II=II+1
SET @DATA@(II)="0^"_$GET(ERR)_$CHAR(30)
+27 IF '$TEST
SET II=II+1
SET @DATA@(II)=MBR_$CHAR(30)
+28 ;
XCLS SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
ISA(USER,CLASS,ERR) ; Boolean - Is USER a Member of CLASS?
+1 NEW USRY,USRI
+2 IF $SELECT(CLASS="USER":1,CLASS=+$ORDER(^USR(8930,"B","USER",0)):1,1:0)
SET USRY=1
GOTO ISAX
+3 IF '+USER
SET USER=+$ORDER(^VA(200,"B",USER,0))
+4 IF +USER'>0
SET ERR="INVALID USER"
QUIT 0
+5 IF '+CLASS
SET CLASS=+$ORDER(^USR(8930,"B",CLASS,0))
+6 IF +CLASS'>0
SET ERR="INVALID USER CLASS"
QUIT 0
+7 ; If USER is a member of CLASS return true
+8 SET USRY=0
+9 IF +$DATA(^USR(8930.3,"AUC",USER,CLASS))
Begin DoDot:1
+10 NEW USRMDA
+11 SET USRMDA=0
+12 FOR
SET USRMDA=+$ORDER(^USR(8930.3,"AUC",USER,CLASS,USRMDA))
IF ((+USRMDA'>0)!(USRY))
QUIT
Begin DoDot:2
+13 SET USRY=+$$CURRENT(USRMDA)
End DoDot:2
End DoDot:1
+14 IF USRY
QUIT USRY
+15 ; Otherwise, check to see if user is a member of any subclass of CLASS
+16 SET USRI=0
+17 FOR
SET USRI=$ORDER(^USR(8930,+CLASS,1,USRI))
IF +USRI'>0!+$GET(USRY)
QUIT
Begin DoDot:1
+18 NEW USRSUB
SET USRSUB=+$GET(^USR(8930,+CLASS,1,USRI,0))
IF +USRSUB'>0
QUIT
+19 ; Recurs to find members of subclass
SET USRY=$$ISA(USER,USRSUB)
End DoDot:1
ISAX QUIT +$GET(USRY)
+1 ;
CURRENT(MEMBER) ; Boolean - Is Membership current?
+1 NEW USRIN,USROUT,USRY
+2 SET USRIN=+$PIECE($GET(^USR(8930.3,+MEMBER,0)),U,3)
+3 SET USROUT=+$PIECE($GET(^USR(8930.3,+MEMBER,0)),U,4)
+4 IF USRIN'>DT
IF $SELECT(USROUT>0&(USROUT'<DT):1,USROUT=0:1,1:0)
SET USRY=1
+5 IF '$TEST
SET USRY=0
+6 QUIT USRY
+7 ;
UPDPOV(VIEN,PIPIEN,PTX) ;EP - Update the POV entry with the new provider text
+1 ;
+2 NEW PKIEN,ICIEN,ICD,POV,DFN,CD
+3 ;
+4 ;Pull Pick List entry
+5 SET PKIEN=$$GET1^DIQ(90680.01,PIPIEN_",",.03,"I")
IF PKIEN=""
QUIT
+6 ;
+7 ;Get the DFN
+8 SET DFN=$$GET1^DIQ(9000010,VIEN,.05,"I")
IF DFN=""
QUIT
+9 ;
+10 ;Locate the current POV entry (entries)
+11 ;
+12 ;Pull the ICD-9(s)
+13 SET ICIEN=0
FOR
SET ICIEN=$ORDER(^BJPN(90680.02,PKIEN,1,ICIEN))
IF 'ICIEN
QUIT
Begin DoDot:1
+14 ;
+15 NEW ICD9,ICDTP,DA,IENS
+16 SET DA(1)=PKIEN
SET DA=ICIEN
SET IENS=$$IENS^DILF(.DA)
+17 SET ICD9=$$GET1^DIQ(90680.21,IENS,.01,"I")
IF ICD9=""
QUIT
+18 SET ICDTP=$$GET1^DIQ(90680.21,IENS,.02,"I")
IF ICDTP'=1
QUIT
+19 SET ICD(ICD9)=$$GET1^DIQ(90680.21,IENS,.01,"E")
End DoDot:1
+20 ;
+21 ;Check for .9999
+22 IF '$DATA(ICD)
Begin DoDot:1
+23 NEW DIC,X,Y
+24 SET DIC="^ICD9("
SET DIC(0)="XMO"
SET X=".9999"
DO ^DIC
IF +Y<0
QUIT
+25 SET ICD(+Y)=".9999"
End DoDot:1
+26 ;
+27 SET POV=""
+28 SET ICIEN=""
FOR
SET ICIEN=$ORDER(^AUPNVPOV("AD",VIEN,ICIEN))
IF ICIEN=""
QUIT
Begin DoDot:1
+29 NEW ICDCD,VPNARR,SNOMED
+30 SET VPNARR=$PIECE($$GET1^DIQ(9000010.07,ICIEN_",",.04,"E"),"|")
+31 SET SNOMED=$$GET1^DIQ(90680.01,PIPIEN_",",.03,"I")
IF SNOMED=""
QUIT
+32 SET SNOMED=$$GET1^DIQ(90680.02,SNOMED_",",.02,"E")
IF SNOMED=""
QUIT
+33 ;
+34 ;Check for normal code match
+35 SET ICDCD=$$GET1^DIQ(9000010.07,ICIEN_",",.01,"I")
IF ICDCD=""
QUIT
+36 IF $DATA(ICD(ICDCD))
IF SNOMED=VPNARR
SET POV=POV_$SELECT(POV]"":";",1:"")_ICIEN
QUIT
+37 ;
+38 QUIT
End DoDot:1
+39 ;
+40 ;Loop through current entries and replace the provider narrative
+41 FOR CD=1:1:$LENGTH(POV,";")
IF $PIECE(POV,";",CD)]""
Begin DoDot:1
+42 ;
+43 NEW RET,N,INP
+44 DO GET^BGOVPOV(.RET,VIEN_U_$PIECE(POV,";",CD))
+45 SET N=$GET(@RET@(1))
+46 SET INP=$PIECE(N,U)_U_$PIECE(N,U,19)_U_"`"_$PIECE(N,U,17)_U_DFN_U_$PIECE($PIECE(N,U,7),"| ")_"| "_PTX
+47 ;Stage
SET $PIECE(INP,U,6)=$PIECE(N,U,10)
+48 ;Modifier
SET $PIECE(INP,U,7)=$$STC(9000010.07,.06,$PIECE(N,U,8))
+49 ;Cause
SET $PIECE(INP,U,8)=$$STC(9000010.07,.07,$PIECE(N,U,12))
+50 ;Visit/Revisit
SET $PIECE(INP,U,9)=$SELECT($PIECE(N,U,11)="REVISIT":2,1:1)
+51 ;E-Code
SET $PIECE(INP,U,10)=$PIECE($PIECE(N,U,14),"~",2)
+52 ;Injury Place
SET $PIECE(INP,U,11)=$PIECE($PIECE(N,U,15),"~",2)
+53 ;Primary/Secondary
SET $PIECE(INP,U,12)=$SELECT($PIECE(N,U,16)="PRIMARY":"P",1:"S")
+54 ;Injury Date
SET $PIECE(INP,U,13)=$$FMTE^XLFDT($PIECE(N,U,13),2)
+55 ;Date of Onset
SET $PIECE(INP,U,14)=$$FMTE^XLFDT($PIECE(N,U,9),2)
+56 ;Asthma
SET $PIECE(INP,U,16)=$PIECE(N,U,21)
+57 DO SET^BGOVPOV(.RET,INP)
End DoDot:1
+58 ;
+59 QUIT
+60 ;
STC(FIL,FLD,VAL) ; EP - Find a code for a set of code value
+1 ; Input Parameters
+2 ; FIL = FileMan File Number
+3 ; FLD = FileMan Field Number
+4 ; VAL = Value
+5 ;
+6 NEW VEDATA,VEQFL,VEVL,VALUE,I
+7 SET VEDATA=$PIECE(^DD(FIL,FLD,0),U,3)
SET VEQFL=0
+8 ;
+9 FOR I=1:1
SET VEVL=$PIECE(VEDATA,";",I)
IF VEVL=""
QUIT
Begin DoDot:1
+10 SET VALUE=$PIECE(VEVL,":",1)
IF VAL=$PIECE(VEVL,":",2)
SET VEQFL=1
End DoDot:1
IF VEQFL
QUIT
+11 ;
+12 QUIT VALUE
