BJPN20P1 ;GDIT/HS/BEE-Prenatal Care Module 2.0 Post Install (Cont.) ; 08 May 2012 12:00 PM
;;2.0;PRENATAL CARE MODULE;;Feb 24, 2015;Build 63
;
Q
;
VOB(BJPNPL,PRBIEN,NEWPRB) ;Copy Care Plan Notes to Visit Instructions, POV info, auditing
;
I $G(BJPNPL)="" Q
;
NEW VBIEN,HIST
;
;Loop through VOB entries for PIP problem
S VBIEN="" F S VBIEN=$O(^AUPNVOB("B",BJPNPL,VBIEN)) Q:VBIEN="" D
. ;
. NEW NTIEN,VIEN,DFN,VDT,EVD,EVD,EPRV,LGIEN,SC,SCND,DA,IENS,VALUE,CHGIEN,AUD,PBAUD,PAUD
. NEW LMDT,LMBY,ENDT,ENBY,INACTIVE,ACTIVE,BPIEN
. ;
. ;Retrieve patient/visit info
. S VIEN=$$GET1^DIQ(9000010.43,VBIEN_",",".03","I") Q:VIEN=""
. S DFN=$$GET1^DIQ(9000010.43,VBIEN_",",".02","I") Q:DFN=""
. S EVD=$$GET1^DIQ(9000010.43,VBIEN_",",1201,"I")
. S:EVD="" EVD=$$GET1^DIQ(9000010,VIEN_",",".01","I")
. S EPRV=$$GET1^DIQ(9000010.43,VBIEN_",",1204,"I")
. ;
. ;Look for notes
. S NTIEN=0 F S NTIEN=$O(^AUPNVOB(VBIEN,21,NTIEN)) Q:'NTIEN D
.. NEW RET,INP,INSTR,DA,IENS,NTDT,NTPV,VVI,EIE,EIEO,ON,BY
.. ;
.. ;Pull info for each note
.. S DA(1)=VBIEN,DA=NTIEN,IENS=$$IENS^DILF(.DA)
.. S NTDT=$$GET1^DIQ(9000010.431,IENS,".02","I") S:NTDT="" NTDT=EVD ;Date
.. S NTPV=$$GET1^DIQ(9000010.431,IENS,".03","I") S:NTPV="" NTPV=EPRV ;Provider
.. S INSTR(0)=$$GET1^DIQ(9000010.431,IENS,".01","I") Q:INSTR(0)=""
.. S INP=U_VIEN_U_PRBIEN_U_DFN_U_NTDT_U_NTPV
.. ;
.. ;API Call to add instruction
.. ;INP = VVI IEN [1] ^ Visit IEN [2] ^ Problem IEN [3] ^ Patient IEN [4]^ Evnt Dt [5] ^ Provider [6]
.. ;INSTR(N)= Array of instructions
.. ;
.. ;Make the API call to add
.. D SET^BJPN20P1(.RET,INP,.INSTR)
.. I '+RET Q
.. S VVI=+RET
.. ;
.. ;Now sign the instruction
.. S RET="" D SIGN^BJPN20P1(.RET,VVI,NTPV,NTDT)
.. ;
.. ;Now see if instruction needs deleted
.. ;
.. S EIE=$$GET1^DIQ(9000010.431,IENS,"2.03","I") Q:EIE=""
.. S EIEO=$$GET1^DIQ(9000010.431,IENS,"2.04","I")
.. S BY=$$GET1^DIQ(9000010.431,IENS,"2.01","I")
.. S ON=$$GET1^DIQ(9000010.431,IENS,"2.02","I")
.. ;
.. ;API Call to enter in error
.. ;INP= Visit instruction ien [1] ^ Reason for eie [2] ^ comment if other [3]
.. ;EIE(RET,INP) ;Mark an entry entered in error
.. S INP=VVI_U_EIE_U_EIEO_U_BY_U_ON
.. D EIE^BJPN20P1(.RET,INP)
. ;
. ;Get the log type
. S VALUE=$P($G(^AUPNVOB(VBIEN,22,1,0)),U,2)
. ;
. ;Process Problem Adds
. S PBAUD=0 I VALUE="Added Problem To PIP" S PBAUD=1
. ;
. ;Handle POV updates/removes
. ;
. ;Determine service category and which node to use
. S SC=$$GET1^DIQ(9000010,VIEN_",",".07","I") Q:SC=""
. S SCND=14 S:SC="H" SCND=15
. S DA(1)=VBIEN,DA=1,IENS=$$IENS^DILF(.DA)
. ;
. ;Set the POV
. I VALUE="Set Problem As POV For Visit" D
.. ;Add POV to the problem multiple
.. Q:PRBIEN=""
.. Q:$D(^AUPNPROB(PRBIEN,SCND,"B",VIEN)) ;Already set
.. N PRIEN,FDA,IEN,ERR
.. S PRIEN="+1,"_PRBIEN_","
.. S FDA("9000011."_SCND,PRIEN,.01)=VIEN
.. D UPDATE^DIE(,"FDA","IEN","ERR")
. ;
. ;Remove the POV
. I VALUE="Removed Problem As POV For Visit" D
.. N IEN,FDA,OKAY,ERR
.. Q:PRBIEN=""
.. ;
.. ;Skip entries set by IPL
.. I $D(^TMP("BJPNCVVOB",$J,PRBIEN,SCND,VIEN)) Q
.. ;
.. ;Remove the entry
.. S IEN="" S IEN=$O(^AUPNPROB(PRBIEN,SCND,"B",VIEN,IEN)) Q:'+IEN D
.. S FDA("9000011."_SCND,IEN_","_PRBIEN_",",.01)="@"
.. D UPDATE^DIE("","FDA","OKAY","ERR")
. ;
. ;Remove the problem from the PIP
. I VALUE="Problem Deleted From PIP" S PBAUD=2
. ;
. ;Audit the entries
. ;
. ;Get Last Modified/Entered info
. S LMDT=$$GET1^DIQ(9000010.43,VBIEN_",",1218,"I")
. S LMBY=$$GET1^DIQ(9000010.43,VBIEN_",",1219,"I")
. S ENDT=$$GET1^DIQ(9000010.43,VBIEN_",",1216,"I")
. S ENBY=$$GET1^DIQ(9000010.43,VBIEN_",",1217,"I")
. S AUD=ENDT_U_ENBY_U_LMDT_U_LMBY
. ;
. ;Get the pointer to the PIP
. S BPIEN=$$GET1^DIQ(9000010.43,VBIEN_",",.01,"I")
. ;
. S CHGIEN=0 F S CHGIEN=$O(^AUPNVOB(VBIEN,22,CHGIEN)) Q:'CHGIEN D
.. NEW NODE,XFLD
.. S NODE=$G(^AUPNVOB(VBIEN,22,CHGIEN,0))
.. I $P(NODE,U)="F" D
... NEW FLD,INVALUE,XNVALUE,IOVALUE,XOVALUE
... S (XFLD,FLD)=$P(NODE,U,2) Q:'+FLD
... I FLD[":" Q ;Skip note entries
... ;
... ;Get the new field values
... S INVALUE=$$GET1^DIQ(9000010.43,VBIEN,FLD,"I")
... S XNVALUE=$$GET1^DIQ(9000010.43,VBIEN,FLD,"E")
... ;Convert 9000010.43 field to 90680.01 field
... S FLD=$S(FLD=".06":".06",FLD=".11":".05",FLD=".08":".07",FLD=".09":".08",FLD=".1":".09",FLD=".12":".04",FLD=1218:"1.03",FLD=1219:"1.04",FLD=1216:"1.01",FLD="1217":"1.02",FLD=".05":".05",1:"")
... ;
... ;Convert SNOMED if needed
... I FLD=".04" S (INVALUE,XNVALUE)=$$GET1^DIQ(90680.02,INVALUE_",",".03","I")
... ;
... ;Skip provider text
... I XFLD=".07" Q
... ;
... I FLD="" Q
... ;
... ;Get the old field values
... S IOVALUE=$G(HIST(FLD,"I"))
... S XOVALUE=$G(HIST(FLD,"X"))
... ;
... ;Quit if field hasn't changed
... I IOVALUE=INVALUE,(+FLD<1.01)!(+FLD>1.04) Q
... ;
... ;Handling for change to inactive/active
... I FLD=".08",INVALUE'="A" S INACTIVE=1
... I FLD=".08",INVALUE="A" S ACTIVE=1
... ;
... ;Set up audit entries
... S AUD(FLD,"I")=IOVALUE_U_INVALUE
... S AUD(FLD,"X")=XOVALUE_U_XNVALUE
... ;
... ;If change in SNOMED, also save Concept ID
... I FLD=".04",NEWPRB D
.... NEW CONCID
.... S PAUD(80002,"I")=$G(HIST(80002,"I"))_U_INVALUE
.... S PAUD(80002,"X")=$G(HIST(80002,"X"))_U_XNVALUE
.... S HIST(80002,"I")=INVALUE
.... S HIST(80002,"X")=XNVALUE
.... S CONCID=$P($$DESC^BSTSAPI(INVALUE_"^^1"),U)
.... I CONCID]"" D
..... S PAUD(80001,"I")=$G(HIST(80001,"I"))_U_CONCID
..... S PAUD(80001,"X")=$G(HIST(80001,"X"))_U_CONCID
..... S HIST(80001,"I")=CONCID
..... S HIST(80001,"X")=CONCID
... ;
... ;Update history with new values
... S HIST(FLD,"I")=INVALUE
... S HIST(FLD,"X")=XNVALUE
. ;
. ;Put in Add entry
. I PBAUD=1 S AUD(".01","I")="^"_BPIEN,AUD(".01","X")="^"_BPIEN
. ;
. ;File PIP audit entries
. I $D(AUD) D AUD^BJPN20AU(.AUD,"90680.01",BJPNPL)
. ;
. ;Manually update Last Modified information
. I LMDT]"" S $P(^AUPNPROB(PRBIEN,0),U,3)=LMDT
. I LMBY]"" S $P(^AUPNPROB(PRBIEN,0),U,14)=LMBY
. I ENDT]"" S $P(^AUPNPROB(PRBIEN,0),U,8)=$P(ENDT,".")
. I ENBY]"" S $P(^AUPNPROB(PRBIEN,1),U,3)=ENBY
. ;
. ;Update PIP info in BJPNPL
. I +$G(PBAUD)!(+$G(INACTIVE))!(+$G(ACTIVE)) D
.. ;
.. NEW UPPIP,DA,DIC,DLAYGO,X,Y,%,ERROR,IENS
.. S DA(1)=BJPNPL,DIC="^BJPNPL("_DA(1)_",5,",DLAYGO=90680.015,DIC(0)=""
.. S X=$G(ENDT) S:X="" X=$G(LMDT)
.. I X="" D NOW^%DTC S X=%
.. K DO,DD D FILE^DICN
.. I +Y<0 Q
.. S DA(1)=BJPNPL,DA=+Y,IENS=$$IENS^DILF(.DA)
.. S X=$G(ENBY) S:X="" X=$G(LMBY)
.. S UPPIP(90680.015,IENS,".02")=$S(+$G(INACTIVE):0,1:1)
.. I X]"" S UPPIP(90680.015,IENS,".03")=X
.. D FILE^DIE("","UPPIP","ERROR")
. ;
. ;File IPL audit entry
. I +$G(PBAUD)!($D(PAUD)>9) D
.. NEW CDINFO
.. S PAUD=ENDT_U_ENBY_U_LMDT_U_LMBY
.. S PAUD(1.03,"I")=U_$P($G(AUD(1.02,"I")),U,2) ;Entered By - Internal
.. S PAUD(1.03,"X")=U_$P($G(AUD(1.02,"X")),U,2) ;Entered By - External
.. S PAUD(1.04,"I")=U_$P($G(AUD(1.02,"I")),U,2) ;Enc Provider - Internal
.. S PAUD(1.04,"X")=U_$P($G(AUD(1.02,"X")),U,2) ;Enc Provider - External
.. S PAUD(.14,"I")=U_$P($G(AUD(1.02,"I")),U,2) ;User Last Modified - Internal
.. S PAUD(.14,"X")=U_$P($G(AUD(1.02,"X")),U,2) ;User Last Modified - External
.. S PAUD(.03,"I")=U_$P($G(AUD(1.01,"I")),U,2) ;Date Last Modified - Internal
.. S PAUD(.03,"X")=U_$P($G(AUD(1.01,"X")),U,2) ;Date Last Modified - External
.. ;
.. ;Save first problem entry
.. I (+$G(PBAUD)=1) D
... S PAUD(.01,"I")=U_$P($G(^AUPNPROB(PRBIEN,0)),U) ;Prob Dx - Internal
... S CDINFO=$$ICDDX^AUPNVUTL($P(PAUD(.01,"I"),U,2),$P(PAUD(.03,"I"),U,2))
... I $P(CDINFO,U)>1 S PAUD(.01,"X")=U_$P(CDINFO,U,2) ;Prob Dx - External
... S PAUD(.08,"I")=U_$P($P($G(AUD(1.01,"I")),U,2),".") ;Date Entered - Internal
... S PAUD(.08,"X")=U_$P($P($G(AUD(1.01,"X")),U,2),"@") ;Date Entered - External
... S PAUD(.12,"I")=U_"E" ;Status - Internal
... S PAUD(.12,"X")=U_"EPISODIC" ;Status - External
... S PAUD(.19,"I")=U_"1" ;PIP
... S PAUD(.19,"X")=U_"YES, ACTIVE IN PIP" ;PIP - External
.. ;
.. ;Manually update the fields
.. I LMDT]"" S $P(^AUPNPROB(PRBIEN,0),U,3)=LMDT
.. I LMBY]"" S $P(^AUPNPROB(PRBIEN,0),U,14)=LMBY
.. I ENDT]"" S $P(^AUPNPROB(PRBIEN,0),U,8)=$P(ENDT,".")
.. I ENBY]"" S $P(^AUPNPROB(PRBIEN,1),U,3)=ENBY
.. ;S $P(^AUPNPROB(PRBIEN,1),U,3)=$P($G(PAUD(1.03,"I")),U,2) ;Entered By
.. ;S $P(^AUPNPROB(PRBIEN,1),U,4)=$P($G(PAUD(1.04,"I")),U,2) ;Enc Prov
.. ;S $P(^AUPNPROB(PRBIEN,0),U,14)=$P($G(PAUD(.14,"I")),U,2) ;User Last Modified
.. ;S $P(^AUPNPROB(PRBIEN,0),U,3)=$P($G(PAUD(.03,"I")),U,2) ;Date Last Modified
.. ;S $P(^AUPNPROB(PRBIEN,0),U,8)=$P($G(PAUD(.08,"I")),U,2) ;Date Entered
.. ;
.. ;Audit the entries
.. D AUD^BJPN20AU(.PAUD,"9000011",PRBIEN)
. ;
. ;Handle PIP problem deletes - remove PIP value and audit
. I $G(PBAUD)=2 D
.. S PAUD(.14,"I")=U_$P($G(AUD(1.02,"I")),U,2) ;User Last Modified - Internal
.. S PAUD(.14,"X")=U_$P($G(AUD(1.02,"X")),U,2) ;User Last Modified - External
.. S PAUD(.03,"I")=U_$P($G(AUD(1.01,"I")),U,2) ;Date Last Modified - Internal
.. S PAUD(.03,"X")=U_$P($G(AUD(1.01,"X")),U,2) ;Date Last Modified - External
.. S PAUD(".19","I")="1^"
.. S PAUD(".19","X")="YES, ACTIVE IN PIP^"
.. ;
.. ;Manually update PIP field
.. S $P(^AUPNPROB(PRBIEN,0),U,19)=""
.. ;
.. ;Audit the entries
.. D AUD^BJPN20AU(.PAUD,"9000011",PRBIEN)
;
Q
;
;This call is based off the SET call in BGOVVI
;It overrides locked visit checking so older care plan notes can be converted
;into visit instructions.
;
;Set data into this file
;INP = VVI IEN [1] ^ Visit IEN [2] ^ Problem IEN [3] ^ Patient IEN [4]^ Evnt Dt [5] ^ Provider [6]
;INSTR(N)= Array of instructions
SET(RET,INP,INSTR) ;EP
N VFIEN,NEW,VIEN,PROB,EVDT,DFN,PRV,FDA,IEN,FNUM,VFNEW
S FNUM=$$FNUM^BGOVVI
S VFIEN=+INP
I VFIEN="" S NEW=1
S VFNEW='VFIEN
S VIEN=$P(INP,U,2)
S PROB=$P(INP,U,3)
I 'PROB S RET="-1^No problem in input string" Q
I 'VIEN S RET=$$ERR^BGOUTL(1008) Q
S DFN=$P(INP,U,4)
S EVDT=$P(INP,U,5)
I EVDT="" S EVDT=$$NOW^XLFDT
S PRV=$P(INP,U,6) I PRV="" S PRV=DUZ
;Do not check visit status
;S RET=$$CHKVISIT^BGOUTL(VIEN,DFN)
;Q:RET
I 'VFIEN D Q:'VFIEN
.D VFNEW^BGOUTL2(.RET,FNUM,PROB,VIEN)
.S:RET>0 VFIEN=RET ;,RET=""
S FDA=$NA(FDA(FNUM,VFIEN_","))
S @FDA@(1201)=EVDT
S @FDA@(1204)="`"_PRV
I VFNEW D
.S @FDA@(1216)="N"
.S @FDA@(1217)="`"_PRV
S @FDA@(1218)="N"
S @FDA@(1219)="`"_PRV
S RET=$$UPDATE^BGOUTL(.FDA,"E@")
I RET,VFNEW,$$DELETE^BGOUTL(FNUM,VFIEN)
Q:RET
;Add in the text of the item
N VAL,ICNT,I
S ICNT=0
S I="" F S I=$O(INSTR(I)) Q:I="" D
.S ICNT=ICNT+1
.S VAL(ICNT,0)=$G(INSTR(I))
D WP^DIE(9000010.58,VFIEN_",",1100,,"VAL")
S RET=VFIEN
;
;Fix the last modified and entered dates
I +VFIEN D
. NEW AUPNVVI
. S AUPNVVI(9000010.58,VFIEN_",",1218)=EVDT
. S AUPNVVI(9000010.58,VFIEN_",",1219)=PRV
. S AUPNVVI(9000010.58,VFIEN_",",1216)=EVDT
. S AUPNVVI(9000010.58,VFIEN_",",1217)=PRV
. D FILE^DIE("","AUPNVVI","ERROR")
;
Q
;
;This call mimics the SIGN call in BGOVVI. It allows for the date to be passed in
;Mark record when signed
SIGN(RET,VVII,BY,ONDT) ;EP
N FDA,AIEN,ERR
S RET="",ERR=""
I $$GET1^DIQ(9000010.58,VVII,.05)'="" S RET="-1^Already signed" Q RET
S AIEN=VVII_","
S:$G(ONDT)="" ONDT=$$NOW^XLFDT
S FDA(9000010.58,AIEN,.04)=BY
S FDA(9000010.58,AIEN,.05)=ONDT
D FILE^DIE("","FDA","ERR")
;
;Fix the last modified and entered dates
I +AIEN D
. NEW AUPNVVI
. S AUPNVVI(9000010.58,AIEN_",",1218)=ONDT
. S AUPNVVI(9000010.58,AIEN_",",1219)=BY
. S AUPNVVI(9000010.58,AIEN_",",1216)=ONDT
. S AUPNVVI(9000010.58,AIEN_",",1217)=BY
. D FILE^DIE("","AUPNVVI","ERROR")
I ERR S RET=-1_U_"Unable to sign Visit Instructions"
Q RET
;
;This call mimics EIE in BGOVVI. It permits the user and dt to be passed in
;Input parameter
;INP= Visit instruction ien [1] ^ Reason for eie [2] ^ comment if other [3] ^ BY [4] ^ Date [5]
EIE(RET,INP) ;Mark an entry entered in error
N FNUM,IEN2,FDA,IEN,REASON,CMMT,IENS,RET,BY,ON
S RET=""
S IENS=$P(INP,U,1)
S REASON=$P(INP,U,2)
S CMMT=$P(INP,U,3)
S BY=$P(INP,U,4) S:BY="" BY=DUZ
S ON=$P(INP,U,5) S:ON="" ON=$$NOW^XLFDT()
S FNUM=9000010.58
S IEN2=IENS_","
S FDA=$NA(FDA(FNUM,IEN2))
S @FDA@(.06)=1
S @FDA@(.07)=BY
S @FDA@(.08)=ON
S @FDA@(.08)=REASON
S @FDA@(.09)=CMMT
S RET=$$UPDATE^BGOUTL(.FDA,,.IEN)
;
;Fix the last modified and entered dates
I +IEN2 D
. NEW AUPNVVI
. S AUPNVVI(9000010.58,IEN2_",",1218)=ON
. S AUPNVVI(9000010.58,IEN2_",",1219)=BY
. S AUPNVVI(9000010.58,IEN2_",",1216)=ON
. S AUPNVVI(9000010.58,IEN2_",",1217)=BY
. D FILE^DIE("","AUPNVVI","ERROR")
;
Q
BJPN20P1 ;GDIT/HS/BEE-Prenatal Care Module 2.0 Post Install (Cont.) ; 08 May 2012 12:00 PM
+1 ;;2.0;PRENATAL CARE MODULE;;Feb 24, 2015;Build 63
+2 ;
+3 QUIT
+4 ;
VOB(BJPNPL,PRBIEN,NEWPRB) ;Copy Care Plan Notes to Visit Instructions, POV info, auditing
+1 ;
+2 IF $GET(BJPNPL)=""
QUIT
+3 ;
+4 NEW VBIEN,HIST
+5 ;
+6 ;Loop through VOB entries for PIP problem
+7 SET VBIEN=""
FOR
SET VBIEN=$ORDER(^AUPNVOB("B",BJPNPL,VBIEN))
IF VBIEN=""
QUIT
Begin DoDot:1
+8 ;
+9 NEW NTIEN,VIEN,DFN,VDT,EVD,EVD,EPRV,LGIEN,SC,SCND,DA,IENS,VALUE,CHGIEN,AUD,PBAUD,PAUD
+10 NEW LMDT,LMBY,ENDT,ENBY,INACTIVE,ACTIVE,BPIEN
+11 ;
+12 ;Retrieve patient/visit info
+13 SET VIEN=$$GET1^DIQ(9000010.43,VBIEN_",",".03","I")
IF VIEN=""
QUIT
+14 SET DFN=$$GET1^DIQ(9000010.43,VBIEN_",",".02","I")
IF DFN=""
QUIT
+15 SET EVD=$$GET1^DIQ(9000010.43,VBIEN_",",1201,"I")
+16 IF EVD=""
SET EVD=$$GET1^DIQ(9000010,VIEN_",",".01","I")
+17 SET EPRV=$$GET1^DIQ(9000010.43,VBIEN_",",1204,"I")
+18 ;
+19 ;Look for notes
+20 SET NTIEN=0
FOR
SET NTIEN=$ORDER(^AUPNVOB(VBIEN,21,NTIEN))
IF 'NTIEN
QUIT
Begin DoDot:2
+21 NEW RET,INP,INSTR,DA,IENS,NTDT,NTPV,VVI,EIE,EIEO,ON,BY
+22 ;
+23 ;Pull info for each note
+24 SET DA(1)=VBIEN
SET DA=NTIEN
SET IENS=$$IENS^DILF(.DA)
+25 ;Date
SET NTDT=$$GET1^DIQ(9000010.431,IENS,".02","I")
IF NTDT=""
SET NTDT=EVD
+26 ;Provider
SET NTPV=$$GET1^DIQ(9000010.431,IENS,".03","I")
IF NTPV=""
SET NTPV=EPRV
+27 SET INSTR(0)=$$GET1^DIQ(9000010.431,IENS,".01","I")
IF INSTR(0)=""
QUIT
+28 SET INP=U_VIEN_U_PRBIEN_U_DFN_U_NTDT_U_NTPV
+29 ;
+30 ;API Call to add instruction
+31 ;INP = VVI IEN [1] ^ Visit IEN [2] ^ Problem IEN [3] ^ Patient IEN [4]^ Evnt Dt [5] ^ Provider [6]
+32 ;INSTR(N)= Array of instructions
+33 ;
+34 ;Make the API call to add
+35 DO SET^BJPN20P1(.RET,INP,.INSTR)
+36 IF '+RET
QUIT
+37 SET VVI=+RET
+38 ;
+39 ;Now sign the instruction
+40 SET RET=""
DO SIGN^BJPN20P1(.RET,VVI,NTPV,NTDT)
+41 ;
+42 ;Now see if instruction needs deleted
+43 ;
+44 SET EIE=$$GET1^DIQ(9000010.431,IENS,"2.03","I")
IF EIE=""
QUIT
+45 SET EIEO=$$GET1^DIQ(9000010.431,IENS,"2.04","I")
+46 SET BY=$$GET1^DIQ(9000010.431,IENS,"2.01","I")
+47 SET ON=$$GET1^DIQ(9000010.431,IENS,"2.02","I")
+48 ;
+49 ;API Call to enter in error
+50 ;INP= Visit instruction ien [1] ^ Reason for eie [2] ^ comment if other [3]
+51 ;EIE(RET,INP) ;Mark an entry entered in error
+52 SET INP=VVI_U_EIE_U_EIEO_U_BY_U_ON
+53 DO EIE^BJPN20P1(.RET,INP)
End DoDot:2
+54 ;
+55 ;Get the log type
+56 SET VALUE=$PIECE($GET(^AUPNVOB(VBIEN,22,1,0)),U,2)
+57 ;
+58 ;Process Problem Adds
+59 SET PBAUD=0
IF VALUE="Added Problem To PIP"
SET PBAUD=1
+60 ;
+61 ;Handle POV updates/removes
+62 ;
+63 ;Determine service category and which node to use
+64 SET SC=$$GET1^DIQ(9000010,VIEN_",",".07","I")
IF SC=""
QUIT
+65 SET SCND=14
IF SC="H"
SET SCND=15
+66 SET DA(1)=VBIEN
SET DA=1
SET IENS=$$IENS^DILF(.DA)
+67 ;
+68 ;Set the POV
+69 IF VALUE="Set Problem As POV For Visit"
Begin DoDot:2
+70 ;Add POV to the problem multiple
+71 IF PRBIEN=""
QUIT
+72 ;Already set
IF $DATA(^AUPNPROB(PRBIEN,SCND,"B",VIEN))
QUIT
+73 NEW PRIEN,FDA,IEN,ERR
+74 SET PRIEN="+1,"_PRBIEN_","
+75 SET FDA("9000011."_SCND,PRIEN,.01)=VIEN
+76 DO UPDATE^DIE(,"FDA","IEN","ERR")
End DoDot:2
+77 ;
+78 ;Remove the POV
+79 IF VALUE="Removed Problem As POV For Visit"
Begin DoDot:2
+80 NEW IEN,FDA,OKAY,ERR
+81 IF PRBIEN=""
QUIT
+82 ;
+83 ;Skip entries set by IPL
+84 IF $DATA(^TMP("BJPNCVVOB",$JOB,PRBIEN,SCND,VIEN))
QUIT
+85 ;
+86 ;Remove the entry
+87 SET IEN=""
SET IEN=$ORDER(^AUPNPROB(PRBIEN,SCND,"B",VIEN,IEN))
IF '+IEN
QUIT
Begin DoDot:3
End DoDot:3
+88 SET FDA("9000011."_SCND,IEN_","_PRBIEN_",",.01)="@"
+89 DO UPDATE^DIE("","FDA","OKAY","ERR")
End DoDot:2
+90 ;
+91 ;Remove the problem from the PIP
+92 IF VALUE="Problem Deleted From PIP"
SET PBAUD=2
+93 ;
+94 ;Audit the entries
+95 ;
+96 ;Get Last Modified/Entered info
+97 SET LMDT=$$GET1^DIQ(9000010.43,VBIEN_",",1218,"I")
+98 SET LMBY=$$GET1^DIQ(9000010.43,VBIEN_",",1219,"I")
+99 SET ENDT=$$GET1^DIQ(9000010.43,VBIEN_",",1216,"I")
+100 SET ENBY=$$GET1^DIQ(9000010.43,VBIEN_",",1217,"I")
+101 SET AUD=ENDT_U_ENBY_U_LMDT_U_LMBY
+102 ;
+103 ;Get the pointer to the PIP
+104 SET BPIEN=$$GET1^DIQ(9000010.43,VBIEN_",",.01,"I")
+105 ;
+106 SET CHGIEN=0
FOR
SET CHGIEN=$ORDER(^AUPNVOB(VBIEN,22,CHGIEN))
IF 'CHGIEN
QUIT
Begin DoDot:2
+107 NEW NODE,XFLD
+108 SET NODE=$GET(^AUPNVOB(VBIEN,22,CHGIEN,0))
+109 IF $PIECE(NODE,U)="F"
Begin DoDot:3
+110 NEW FLD,INVALUE,XNVALUE,IOVALUE,XOVALUE
+111 SET (XFLD,FLD)=$PIECE(NODE,U,2)
IF '+FLD
QUIT
+112 ;Skip note entries
IF FLD[":"
QUIT
+113 ;
+114 ;Get the new field values
+115 SET INVALUE=$$GET1^DIQ(9000010.43,VBIEN,FLD,"I")
+116 SET XNVALUE=$$GET1^DIQ(9000010.43,VBIEN,FLD,"E")
+117 ;Convert 9000010.43 field to 90680.01 field
+118 SET FLD=$SELECT(FLD=".06":".06",FLD=".11":".05",FLD=".08":".07",FLD=".09":".08",FLD=".1":".09",FLD=".12":".04",FLD=1218:"1.03",FLD=1219:"1.04",FLD=1216:"1.01",FLD="1217":"1.02",FLD=".05":".05",1:"")
+119 ;
+120 ;Convert SNOMED if needed
+121 IF FLD=".04"
SET (INVALUE,XNVALUE)=$$GET1^DIQ(90680.02,INVALUE_",",".03","I")
+122 ;
+123 ;Skip provider text
+124 IF XFLD=".07"
QUIT
+125 ;
+126 IF FLD=""
QUIT
+127 ;
+128 ;Get the old field values
+129 SET IOVALUE=$GET(HIST(FLD,"I"))
+130 SET XOVALUE=$GET(HIST(FLD,"X"))
+131 ;
+132 ;Quit if field hasn't changed
+133 IF IOVALUE=INVALUE
IF (+FLD<1.01)!(+FLD>1.04)
QUIT
+134 ;
+135 ;Handling for change to inactive/active
+136 IF FLD=".08"
IF INVALUE'="A"
SET INACTIVE=1
+137 IF FLD=".08"
IF INVALUE="A"
SET ACTIVE=1
+138 ;
+139 ;Set up audit entries
+140 SET AUD(FLD,"I")=IOVALUE_U_INVALUE
+141 SET AUD(FLD,"X")=XOVALUE_U_XNVALUE
+142 ;
+143 ;If change in SNOMED, also save Concept ID
+144 IF FLD=".04"
IF NEWPRB
Begin DoDot:4
+145 NEW CONCID
+146 SET PAUD(80002,"I")=$GET(HIST(80002,"I"))_U_INVALUE
+147 SET PAUD(80002,"X")=$GET(HIST(80002,"X"))_U_XNVALUE
+148 SET HIST(80002,"I")=INVALUE
+149 SET HIST(80002,"X")=XNVALUE
+150 SET CONCID=$PIECE($$DESC^BSTSAPI(INVALUE_"^^1"),U)
+151 IF CONCID]""
Begin DoDot:5
+152 SET PAUD(80001,"I")=$GET(HIST(80001,"I"))_U_CONCID
+153 SET PAUD(80001,"X")=$GET(HIST(80001,"X"))_U_CONCID
+154 SET HIST(80001,"I")=CONCID
+155 SET HIST(80001,"X")=CONCID
End DoDot:5
End DoDot:4
+156 ;
+157 ;Update history with new values
+158 SET HIST(FLD,"I")=INVALUE
+159 SET HIST(FLD,"X")=XNVALUE
End DoDot:3
End DoDot:2
+160 ;
+161 ;Put in Add entry
+162 IF PBAUD=1
SET AUD(".01","I")="^"_BPIEN
SET AUD(".01","X")="^"_BPIEN
+163 ;
+164 ;File PIP audit entries
+165 IF $DATA(AUD)
DO AUD^BJPN20AU(.AUD,"90680.01",BJPNPL)
+166 ;
+167 ;Manually update Last Modified information
+168 IF LMDT]""
SET $PIECE(^AUPNPROB(PRBIEN,0),U,3)=LMDT
+169 IF LMBY]""
SET $PIECE(^AUPNPROB(PRBIEN,0),U,14)=LMBY
+170 IF ENDT]""
SET $PIECE(^AUPNPROB(PRBIEN,0),U,8)=$PIECE(ENDT,".")
+171 IF ENBY]""
SET $PIECE(^AUPNPROB(PRBIEN,1),U,3)=ENBY
+172 ;
+173 ;Update PIP info in BJPNPL
+174 IF +$GET(PBAUD)!(+$GET(INACTIVE))!(+$GET(ACTIVE))
Begin DoDot:2
+175 ;
+176 NEW UPPIP,DA,DIC,DLAYGO,X,Y,%,ERROR,IENS
+177 SET DA(1)=BJPNPL
SET DIC="^BJPNPL("_DA(1)_",5,"
SET DLAYGO=90680.015
SET DIC(0)=""
+178 SET X=$GET(ENDT)
IF X=""
SET X=$GET(LMDT)
+179 IF X=""
DO NOW^%DTC
SET X=%
+180 KILL DO,DD
DO FILE^DICN
+181 IF +Y<0
QUIT
+182 SET DA(1)=BJPNPL
SET DA=+Y
SET IENS=$$IENS^DILF(.DA)
+183 SET X=$GET(ENBY)
IF X=""
SET X=$GET(LMBY)
+184 SET UPPIP(90680.015,IENS,".02")=$SELECT(+$GET(INACTIVE):0,1:1)
+185 IF X]""
SET UPPIP(90680.015,IENS,".03")=X
+186 DO FILE^DIE("","UPPIP","ERROR")
End DoDot:2
+187 ;
+188 ;File IPL audit entry
+189 IF +$GET(PBAUD)!($DATA(PAUD)>9)
Begin DoDot:2
+190 NEW CDINFO
+191 SET PAUD=ENDT_U_ENBY_U_LMDT_U_LMBY
+192 ;Entered By - Internal
SET PAUD(1.03,"I")=U_$PIECE($GET(AUD(1.02,"I")),U,2)
+193 ;Entered By - External
SET PAUD(1.03,"X")=U_$PIECE($GET(AUD(1.02,"X")),U,2)
+194 ;Enc Provider - Internal
SET PAUD(1.04,"I")=U_$PIECE($GET(AUD(1.02,"I")),U,2)
+195 ;Enc Provider - External
SET PAUD(1.04,"X")=U_$PIECE($GET(AUD(1.02,"X")),U,2)
+196 ;User Last Modified - Internal
SET PAUD(.14,"I")=U_$PIECE($GET(AUD(1.02,"I")),U,2)
+197 ;User Last Modified - External
SET PAUD(.14,"X")=U_$PIECE($GET(AUD(1.02,"X")),U,2)
+198 ;Date Last Modified - Internal
SET PAUD(.03,"I")=U_$PIECE($GET(AUD(1.01,"I")),U,2)
+199 ;Date Last Modified - External
SET PAUD(.03,"X")=U_$PIECE($GET(AUD(1.01,"X")),U,2)
+200 ;
+201 ;Save first problem entry
+202 IF (+$GET(PBAUD)=1)
Begin DoDot:3
+203 ;Prob Dx - Internal
SET PAUD(.01,"I")=U_$PIECE($GET(^AUPNPROB(PRBIEN,0)),U)
+204 SET CDINFO=$$ICDDX^AUPNVUTL($PIECE(PAUD(.01,"I"),U,2),$PIECE(PAUD(.03,"I"),U,2))
+205 ;Prob Dx - External
IF $PIECE(CDINFO,U)>1
SET PAUD(.01,"X")=U_$PIECE(CDINFO,U,2)
+206 ;Date Entered - Internal
SET PAUD(.08,"I")=U_$PIECE($PIECE($GET(AUD(1.01,"I")),U,2),".")
+207 ;Date Entered - External
SET PAUD(.08,"X")=U_$PIECE($PIECE($GET(AUD(1.01,"X")),U,2),"@")
+208 ;Status - Internal
SET PAUD(.12,"I")=U_"E"
+209 ;Status - External
SET PAUD(.12,"X")=U_"EPISODIC"
+210 ;PIP
SET PAUD(.19,"I")=U_"1"
+211 ;PIP - External
SET PAUD(.19,"X")=U_"YES, ACTIVE IN PIP"
End DoDot:3
+212 ;
+213 ;Manually update the fields
+214 IF LMDT]""
SET $PIECE(^AUPNPROB(PRBIEN,0),U,3)=LMDT
+215 IF LMBY]""
SET $PIECE(^AUPNPROB(PRBIEN,0),U,14)=LMBY
+216 IF ENDT]""
SET $PIECE(^AUPNPROB(PRBIEN,0),U,8)=$PIECE(ENDT,".")
+217 IF ENBY]""
SET $PIECE(^AUPNPROB(PRBIEN,1),U,3)=ENBY
+218 ;S $P(^AUPNPROB(PRBIEN,1),U,3)=$P($G(PAUD(1.03,"I")),U,2) ;Entered By
+219 ;S $P(^AUPNPROB(PRBIEN,1),U,4)=$P($G(PAUD(1.04,"I")),U,2) ;Enc Prov
+220 ;S $P(^AUPNPROB(PRBIEN,0),U,14)=$P($G(PAUD(.14,"I")),U,2) ;User Last Modified
+221 ;S $P(^AUPNPROB(PRBIEN,0),U,3)=$P($G(PAUD(.03,"I")),U,2) ;Date Last Modified
+222 ;S $P(^AUPNPROB(PRBIEN,0),U,8)=$P($G(PAUD(.08,"I")),U,2) ;Date Entered
+223 ;
+224 ;Audit the entries
+225 DO AUD^BJPN20AU(.PAUD,"9000011",PRBIEN)
End DoDot:2
+226 ;
+227 ;Handle PIP problem deletes - remove PIP value and audit
+228 IF $GET(PBAUD)=2
Begin DoDot:2
+229 ;User Last Modified - Internal
SET PAUD(.14,"I")=U_$PIECE($GET(AUD(1.02,"I")),U,2)
+230 ;User Last Modified - External
SET PAUD(.14,"X")=U_$PIECE($GET(AUD(1.02,"X")),U,2)
+231 ;Date Last Modified - Internal
SET PAUD(.03,"I")=U_$PIECE($GET(AUD(1.01,"I")),U,2)
+232 ;Date Last Modified - External
SET PAUD(.03,"X")=U_$PIECE($GET(AUD(1.01,"X")),U,2)
+233 SET PAUD(".19","I")="1^"
+234 SET PAUD(".19","X")="YES, ACTIVE IN PIP^"
+235 ;
+236 ;Manually update PIP field
+237 SET $PIECE(^AUPNPROB(PRBIEN,0),U,19)=""
+238 ;
+239 ;Audit the entries
+240 DO AUD^BJPN20AU(.PAUD,"9000011",PRBIEN)
End DoDot:2
End DoDot:1
+241 ;
+242 QUIT
+243 ;
+244 ;This call is based off the SET call in BGOVVI
+245 ;It overrides locked visit checking so older care plan notes can be converted
+246 ;into visit instructions.
+247 ;
+248 ;Set data into this file
+249 ;INP = VVI IEN [1] ^ Visit IEN [2] ^ Problem IEN [3] ^ Patient IEN [4]^ Evnt Dt [5] ^ Provider [6]
+250 ;INSTR(N)= Array of instructions
SET(RET,INP,INSTR) ;EP
+1 NEW VFIEN,NEW,VIEN,PROB,EVDT,DFN,PRV,FDA,IEN,FNUM,VFNEW
+2 SET FNUM=$$FNUM^BGOVVI
+3 SET VFIEN=+INP
+4 IF VFIEN=""
SET NEW=1
+5 SET VFNEW='VFIEN
+6 SET VIEN=$PIECE(INP,U,2)
+7 SET PROB=$PIECE(INP,U,3)
+8 IF 'PROB
SET RET="-1^No problem in input string"
QUIT
+9 IF 'VIEN
SET RET=$$ERR^BGOUTL(1008)
QUIT
+10 SET DFN=$PIECE(INP,U,4)
+11 SET EVDT=$PIECE(INP,U,5)
+12 IF EVDT=""
SET EVDT=$$NOW^XLFDT
+13 SET PRV=$PIECE(INP,U,6)
IF PRV=""
SET PRV=DUZ
+14 ;Do not check visit status
+15 ;S RET=$$CHKVISIT^BGOUTL(VIEN,DFN)
+16 ;Q:RET
+17 IF 'VFIEN
Begin DoDot:1
+18 DO VFNEW^BGOUTL2(.RET,FNUM,PROB,VIEN)
+19 ;,RET=""
IF RET>0
SET VFIEN=RET
End DoDot:1
IF 'VFIEN
QUIT
+20 SET FDA=$NAME(FDA(FNUM,VFIEN_","))
+21 SET @FDA@(1201)=EVDT
+22 SET @FDA@(1204)="`"_PRV
+23 IF VFNEW
Begin DoDot:1
+24 SET @FDA@(1216)="N"
+25 SET @FDA@(1217)="`"_PRV
End DoDot:1
+26 SET @FDA@(1218)="N"
+27 SET @FDA@(1219)="`"_PRV
+28 SET RET=$$UPDATE^BGOUTL(.FDA,"E@")
+29 IF RET
IF VFNEW
IF $$DELETE^BGOUTL(FNUM,VFIEN)
+30 IF RET
QUIT
+31 ;Add in the text of the item
+32 NEW VAL,ICNT,I
+33 SET ICNT=0
+34 SET I=""
FOR
SET I=$ORDER(INSTR(I))
IF I=""
QUIT
Begin DoDot:1
+35 SET ICNT=ICNT+1
+36 SET VAL(ICNT,0)=$GET(INSTR(I))
End DoDot:1
+37 DO WP^DIE(9000010.58,VFIEN_",",1100,,"VAL")
+38 SET RET=VFIEN
+39 ;
+40 ;Fix the last modified and entered dates
+41 IF +VFIEN
Begin DoDot:1
+42 NEW AUPNVVI
+43 SET AUPNVVI(9000010.58,VFIEN_",",1218)=EVDT
+44 SET AUPNVVI(9000010.58,VFIEN_",",1219)=PRV
+45 SET AUPNVVI(9000010.58,VFIEN_",",1216)=EVDT
+46 SET AUPNVVI(9000010.58,VFIEN_",",1217)=PRV
+47 DO FILE^DIE("","AUPNVVI","ERROR")
End DoDot:1
+48 ;
+49 QUIT
+50 ;
+51 ;This call mimics the SIGN call in BGOVVI. It allows for the date to be passed in
+52 ;Mark record when signed
SIGN(RET,VVII,BY,ONDT) ;EP
+1 NEW FDA,AIEN,ERR
+2 SET RET=""
SET ERR=""
+3 IF $$GET1^DIQ(9000010.58,VVII,.05)'=""
SET RET="-1^Already signed"
QUIT RET
+4 SET AIEN=VVII_","
+5 IF $GET(ONDT)=""
SET ONDT=$$NOW^XLFDT
+6 SET FDA(9000010.58,AIEN,.04)=BY
+7 SET FDA(9000010.58,AIEN,.05)=ONDT
+8 DO FILE^DIE("","FDA","ERR")
+9 ;
+10 ;Fix the last modified and entered dates
+11 IF +AIEN
Begin DoDot:1
+12 NEW AUPNVVI
+13 SET AUPNVVI(9000010.58,AIEN_",",1218)=ONDT
+14 SET AUPNVVI(9000010.58,AIEN_",",1219)=BY
+15 SET AUPNVVI(9000010.58,AIEN_",",1216)=ONDT
+16 SET AUPNVVI(9000010.58,AIEN_",",1217)=BY
+17 DO FILE^DIE("","AUPNVVI","ERROR")
End DoDot:1
+18 IF ERR
SET RET=-1_U_"Unable to sign Visit Instructions"
+19 QUIT RET
+20 ;
+21 ;This call mimics EIE in BGOVVI. It permits the user and dt to be passed in
+22 ;Input parameter
+23 ;INP= Visit instruction ien [1] ^ Reason for eie [2] ^ comment if other [3] ^ BY [4] ^ Date [5]
EIE(RET,INP) ;Mark an entry entered in error
+1 NEW FNUM,IEN2,FDA,IEN,REASON,CMMT,IENS,RET,BY,ON
+2 SET RET=""
+3 SET IENS=$PIECE(INP,U,1)
+4 SET REASON=$PIECE(INP,U,2)
+5 SET CMMT=$PIECE(INP,U,3)
+6 SET BY=$PIECE(INP,U,4)
IF BY=""
SET BY=DUZ
+7 SET ON=$PIECE(INP,U,5)
IF ON=""
SET ON=$$NOW^XLFDT()
+8 SET FNUM=9000010.58
+9 SET IEN2=IENS_","
+10 SET FDA=$NAME(FDA(FNUM,IEN2))
+11 SET @FDA@(.06)=1
+12 SET @FDA@(.07)=BY
+13 SET @FDA@(.08)=ON
+14 SET @FDA@(.08)=REASON
+15 SET @FDA@(.09)=CMMT
+16 SET RET=$$UPDATE^BGOUTL(.FDA,,.IEN)
+17 ;
+18 ;Fix the last modified and entered dates
+19 IF +IEN2
Begin DoDot:1
+20 NEW AUPNVVI
+21 SET AUPNVVI(9000010.58,IEN2_",",1218)=ON
+22 SET AUPNVVI(9000010.58,IEN2_",",1219)=BY
+23 SET AUPNVVI(9000010.58,IEN2_",",1216)=ON
+24 SET AUPNVVI(9000010.58,IEN2_",",1217)=BY
+25 DO FILE^DIE("","AUPNVVI","ERROR")
End DoDot:1
+26 ;
+27 QUIT
