BGOCPLAN ; IHS/BAO/TMD - pull V Care Plan data ;27-Jan-2016 09:53;DU
;;1.1;BGO COMPONENTS;**13,14,17,19**;Mar 20, 2007;Build 5
;P14 changed to return time when entered
;---------------------------------------------
GET(DATA,IEN,DFN,TYPE,RETI,CNT,PRV) ;EP
;Find the latest number of entries for each section using the
;parameter and return them to the calling program
;Input is IEN = Problem
; DFN = Patient
; TYPE = G(oal) or C(are Plan)
; RETI = Return types (A(active),C(complete),L(latest)
; CNT = Count
; PRV = Provider to look for data on
;Ouput: Array in the format
;Array(n)=Type (G OR C) [1] ^ C Plan IEN [2] ^ Prob IEN [4] ^ Who entered [4] ^ Date Entered [5] ^ Status [6] ^ SIGN FLAG [7]
; =~t [1] ^ Text of the item [2]
N GCNT,INVDT,NODE,FNUM,CODE,DONE,STA,STAT,SDATE,CPIEN,SIEN,SORT
S DONE=0,SDATE=0
I $G(RETI)="" S RETI="L"
I $G(DATA)="" S DATA=$$TMPGBL
I $G(CNT)="" S CNT=1
S PRV=$G(PRV)
I RETI="" S RETI="L"
S INVDT=""
S TYPE=$S(TYPE="C":"P",1:TYPE)
I PRV'="" D
.F S INVDT=$O(^AUPNCPL("APTP",IEN,TYPE,PRV,INVDT)) Q:INVDT=""!(DONE=1) D
..S CPIEN="" F S CPIEN=$O(^AUPNCPL("APTP",IEN,TYPE,PRV,INVDT,CPIEN)) Q:CPIEN="" D
...S SIEN=$C(0) S SIEN=$O(^AUPNCPL(CPIEN,11,SIEN),-1)
...S STATUS=$P($G(^AUPNCPL(CPIEN,11,SIEN,0)),U,1)
...Q:STATUS="E"
...Q:(STATUS="R")&(RETI'="C")
...S SORT(INVDT,CPIEN,SIEN)=""
...;D DATA(.DATA,CPIEN,SIEN)
.D DATA(.DATA,.SORT)
I PRV="" D
.S CPIEN="" F S CPIEN=$O(^AUPNCPL("APT",IEN,TYPE,CPIEN)) Q:CPIEN=""!(DONE=1) D
..S SIEN=$C(0) S SIEN=$O(^AUPNCPL(CPIEN,11,SIEN),-1)
..S STATUS=$P($G(^AUPNCPL(CPIEN,11,SIEN,0)),U,1)
..Q:STATUS="E"
..Q:(STATUS="R")&(RETI'="C")
..;D DATA(.DATA,CPIEN,SIEN)
..S INVDT=9999999-$P($G(^AUPNCPL(CPIEN,0)),U,5)
..S SORT(INVDT,CPIEN,SIEN)=""
.D DATA(.DATA,.SORT)
Q
IEN(DATA) ;FIND IEN
Q:STATUS="E"
I RETI="C"!(STATUS="A"&((RETI="A")!(RETI="L"))) D
.S CPIEN="" S CPIEN=$O(^AUPNCPL("ASDT",IEN,TYPE,INVDT,STATUS,CPIEN)) Q:CPIEN="" D
..S SIEN="" F S SIEN=$O(^AUPNCPL("ASDT",IEN,TYPE,INVDT,STATUS,CPIEN,SIEN),-1) Q:SIEN="" D
..S SORT(INVDT,CPIEN,SIEN)=""
.D DATA(.DATA,.SORT)
Q
DATA(DATA,SORT) ;Get data for this item
N INVDT,CPIEN,SIEN
S INVDT="" F S INVDT=$O(SORT(INVDT)) Q:INVDT="" D
.S CPIEN="" F S CPIEN=$O(SORT(INVDT,CPIEN)) Q:CPIEN="" D
..S SIEN="" F S SIEN=$O(SORT(INVDT,CPIEN,SIEN)) Q:SIEN="" D
...D DATA1(.DATA,CPIEN,SIEN)
Q
DATA1(DATA,CPIEN,SIEN) ;Get data for one plan
N BY,WHEN,LIEN,TXT,TXTIEN,PTYPE,SIGNED,PROB,SIG
S FNUM=9000092.11
S SIGNED=0
S SIGNED=$P($G(^AUPNCPL(CPIEN,0)),U,7)
;Q:(SIGNED="")&(DUZ'=$$GET1^DIQ(9000092,CPIEN,.03,"I")) ;DKA 9/9/13 Don't filter out
S NODE=$G(^AUPNCPL(CPIEN,11,SIEN,0))
I SDATE=0 S SDATE=$P(INVDT,".",1)
I RETI="L"&(SDATE'=$P(INVDT,".",1)) S DONE=1
Q:+DONE
S CNT=CNT+1
S LIEN=SIEN_","_CPIEN
S WHEN=$$GET1^DIQ(FNUM,LIEN,.03,"I")
S WHEN=$$FMTDATE^BGOUTL(WHEN,1)
S BY=$$GET1^DIQ(FNUM,LIEN,.02,"E")
S STAT=$$GET1^DIQ(FNUM,LIEN,.01,"I")
S PTYPE=$S(TYPE="P":"C",1:"G")
S SIG=$$GET1^DIQ(9000092,CPIEN,.08,"I")
I SIG'="" S SIG=$$FMTDATE^BGOUTL(SIG)
;S @DATA@(CNT)=PTYPE_U_CPIEN_U_IEN_U_BY_U_WHEN_U_STAT_U_SIGNED
S @DATA@(CNT)=PTYPE_U_CPIEN_U_IEN_U_BY_U_WHEN_U_STAT_U_SIG
S TXTIEN=0 F S TXTIEN=$O(^AUPNCPL(CPIEN,12,TXTIEN)) Q:'+TXTIEN D
.S CNT=CNT+1
.;IHS/MSC/MGH changed for carriage returns P17
.S @DATA@(CNT)="~t"_U_$TR($G(^AUPNCPL(CPIEN,12,TXTIEN,0)),$C(13,10))
Q
Q
; Input Variables
; DFN = Patient
; PRIEN = problem this plan belongs to
; INP = G(goal) or P(Care plan)[1] ^ IEN [2] (blank if new) ^ EDT(event dt/time) [3] ^ Provider [4]
; STATUS = SIEN [1] ^ STATUS [2] ^ WHO ENTERED [3] ^ WHEN [4] ^ Old Item if replaced [5] ^ REASON EIE [6]^ REASON IF OTHER [7] ^ Comment [8]
; TEXT(n) = Text of the item
SET(RET,DFN,PRIEN,INP,STATUS,TEXT) ;EP
N FDA,IEN,FPNUM,CIEN,FNUM,IENS,PRNEW,PRIOR,SNOCT,DESCT,X,PIEN
N TYP,IEN,EDT,PRV,OLD,SIEN,WHO,WHEN,STAT,OLDIEN,NEWIEN,STAT2,X2
S FNUM=$$FNUM,RET="",ERR=0,OLD=""
I $G(PRIEN)="" S RET="1^No Problem was input and care planning cannot be saved" Q
S TYP=$S($P(INP,U,1)="C":"P",1:$P(INP,U,1))
S IEN=$P(INP,U,2),EDT=$P(INP,U,3),PRV=$P(INP,U,4)
;IHS/MSC/MGH Fix for sending in a zero
I IEN=0 S IEN=""
I TYP="" S RET="1^A Care Planning type was not entered. Cannot save item" Q
S STAT=$P(STATUS,U,2)
I STAT="" S RET="1^No status was entered and care planning cannot be saved" Q
I IEN="" S CIEN="+1,"
E S CIEN=IEN_","
I EDT="" S EDT=$$NOW^XLFDT
I PRV="" S PRV=DUZ
I $P(STATUS,U,4)'="" S OLD=$P(STATUS,U,5)
S FDA=$NA(FDA(FNUM,CIEN))
S @FDA@(.01)=PRIEN
S @FDA@(.02)=DFN
S @FDA@(.03)=PRV
S @FDA@(.04)=TYP
S @FDA@(.05)=EDT
S @FDA@(.06)=$$NOW^XLFDT
I OLD'="" S @FDA@(.09)=OLD
S RET=$$UPDATE^BGOUTL(.FDA,,.PIEN)
Q:RET
S:'IEN IEN=PIEN(1)
S:'RET RET=IEN
;Add in the status multiple if it hasn't changed
S SIEN=$P(STATUS,U,1)
S X2=$C(0)
;Find the latest status
S X2=$O(^AUPNCPL(IEN,11,X2),-1)
I X2'="" D
.S STAT2=$P($G(^AUPNCPL(IEN,11,X2,0)),U,1)
.I STAT'=STAT2 S SIEN="" ;Add new entry if status changed
.E S SIEN=X2
S WHO=$P(STATUS,U,3)
S WHEN=$P(STATUS,U,4)
I WHO="" S WHO=DUZ
I WHEN="" S WHEN=$$NOW^XLFDT
I SIEN="" S SIEN="+1,"_IEN_","
E S SIEN=SIEN_","_IEN_","
N FDA,ERR,IEN2
S FDA(9000092.11,SIEN,.01)=STAT
S FDA(9000092.11,SIEN,.02)=WHO
S FDA(9000092.11,SIEN,.03)=WHEN
S FDA(9000092.11,SIEN,1)=$P(STATUS,U,8)
I STAT="E"!(STAT="ENTERED IN ERROR") D
.S FDA(9000092.11,SIEN,.04)=$P(STATUS,U,6)
.S FDA(9000091.11,SIEN,.05)=$P(STATUS,U,7)
D UPDATE^DIE(,"FDA","IEN2","ERR")
I $G(ERR("DIERR",1)) S RET=-ERR("DIERR",1)_U_ERR("DIERR",1,"TEXT",1) Q
;Add in the text of the item if its not signed
I $$GET1^DIQ(9000092,IEN,.07)="" D
.N TXT,TCNT,I
.S TCNT=0
.S I="" F S I=$O(TEXT(I)) Q:I="" D
..S TCNT=TCNT+1
..S TXT(TCNT,0)=$G(TEXT(I))
.D WP^DIE(9000092,IEN_",",1200,,"TXT")
;if replaced update original
I +OLD D UPDATE(OLD)
Q
UPDATE(OLD) ;Update data
N OLDIEN,FDA,ERR,IEN2
S OLDIEN="+1,"_OLD_","
S FDA=$NA(FDA(FNUM,OLDIEN))
S FDA(9000092.11,OLDIEN,.01)="R"
S FDA(9000092.11,OLDIEN,.02)=WHO
S FDA(9000092.11,OLDIEN,.03)=WHEN
S FDA(9000092.11,OLDIEN,.06)=IEN
D UPDATE^DIE(,"FDA","IEN2","ERR")
Q
LOOK(SNOMED) ;Lookup snomed term
N RET
S RET=$P($$DESC^BSTSAPI(SNOMED_"^^1"),U,2)
Q RET
;Sign the plan
;Input=IEN of the entry
;Provider who is signing
SIGN(RET,IEN,PRV) ;Sign the entry
N FNUM,FDA,IEN2,ERR,AIEN
S RET="",ERR=""
S AIEN=IEN_","
S FDA(9000092,AIEN,.07)=PRV
S FDA(9000092,AIEN,.08)=$$NOW^XLFDT
D FILE^DIE("","FDA","ERR")
I ERR S RET=-1_U_"Unable to sign Care Plan"
Q
; Delete a Care Plan entry
DEL(RET,PLAN) ;EP
N GBL
I $G(PLAN)="" S RET="-1^Care Plan number not entered" Q
I $$GET1^DIQ(9000092,PLAN,.07)'="" S RET="-1^Already signed" Q
S GBL=$$ROOT^DILFD($$FNUM,,1),RET=""
S FNUM=$$FNUM^BGOCPLAN
Q:'PLAN
I '$L(GBL) S RET=$$ERR^BGOUTL(1069) Q
S RET=$$DELETE^BGOUTL(FNUM,PLAN)
D:'RET VFEVT^BGOUTL2(FNUM,PLAN,2,X)
Q
UPSTAT(RET,IEN,PROB,STAT,COMM) ;Change the status of a care plan or goal
N AIEN,FDA,ERR,SIEN,IEN2
S RET=""
S SIEN="+1,"_IEN_","
S FDA(9000092.11,SIEN,.01)=STAT
S FDA(9000092.11,SIEN,.02)=DUZ
S FDA(9000092.11,SIEN,.03)=$$NOW^XLFDT
;S FDA(9000092.11,SIEN,1)=COMM
S:$G(COMM)'="" FDA(9000092.11,SIEN,1)=COMM ;2013-09-10 DKA P13 Allow blank comment
D UPDATE^DIE(,"FDA","IEN2","ERR")
I $D(ERR)>0 S RET="-1^Unable to update status"
Q
;Input parameter
;INP= Problem ien [1] ^ Reason for eie [2] ^ comment if other [3]
EIE(RET,INP) ;Mark an entry entered in error
N FNUM,IEN2,FDA,IEN,REASON,CMMT,IENS,RET
S RET=""
S IENS=$P(INP,U,1)
S REASON=$P(INP,U,2)
S CMMT=$P(INP,U,3)
S FNUM=9000092.11
S IEN2="+1,"_IENS_","
S FDA=$NA(FDA(FNUM,IEN2))
S @FDA@(.01)="E"
S @FDA@(.02)=DUZ
S @FDA@(.03)=$$NOW^XLFDT()
S @FDA@(.04)=REASON
S @FDA@(.04)=CMMT
S RET=$$UPDATE^BGOUTL(.FDA,,.IEN)
Q
;EIE can only be done by the author or the chief of MIS
;Input = IEN of the entry [1] ^ user deleting [2]
OKDEL(RET,IEN,USER) ;EP Can this user delete
N PRV,ENTRYDT,ERR
S RET=0
I $G(USER)="" S USER=DUZ
S PRV=$$GET1^DIQ(9000092,IEN,.03,"I")
I PRV=USER S RET=1 Q
S ENTRYDT=$$NOW^XLFDT
S ERR=""
S RET=$$ISA^TIUPS139(USER,"CHIEF, MIS",ERR)
Q
PAR(INP) Q $S($$GET^XPAR("SYS","BEH PARAMETER",INP)>0:$$GET^XPAR("SYS","BEH PARAMETER",INP),1:1)
TMPGBL(X) ;EP
K ^TMP("BGOPLAN"_$G(X),$J) Q $NA(^($J))
; Return file number
FNUM() Q 9000092
; Use parameters to get and load TIU templates into the care plan
; Nodes Returned by GETITEMS
;
; Piece Data
; ----- ---------------------
; 1 IEN
; 2 TYPE
; 3 STATUS
; 4 NAME
; 5 EXCLUDE FROM GROUP BOILERPLATE
; 6 BLANK LINES
; 7 PERSONAL OWNER
; 8 HAS CHILDREN FLAG (0=NONE, 1=ACTIVE, 2=INACTIVE, 3=BOTH)
; 9 DIALOG
; 10 DISPLAY ONLY
; 11 FIRST LINE
; 12 ONE ITEM ONLY
; 13 HIDE DIALOG ITEMS
; 14 HIDE TREE ITEMS
; 15 INDENT ITEMS
; 16 REMINDER DIALOG IEN
; 17 REMINDER DIALOG NAME
; 18 LOCKED
; 19 COM OBJECT POINTER
; 20 COM OBJECT PARAMETER
; 21 LINK POINTER
GETROOTS(TIUY,USER,PARAM) ;Get template root info
N IDX,TIUDA,TYPE,PARAM,ENT,ARY,ERR,LP
S ENT=$$ENT^CIAVMRPC(PARAM,.ENT)
D GETLST^XPAR(.ARY,ENT,PARAM,"N",.ERR)
I $G(ERR) K ARY S DATA=ERR
S LP=0 F S LP=$O(ARY(LP)) Q:LP<1 D
.S TIUDA=$P(ARY(LP),U,1)
.D ADDNODE(.IDX,TIUDA,1)
Q
ADDNODE(IDX,TIUDA,INTIUY) ;Adds template node info
N DATA
S DATA=$$NODEDATA^TIUSRVT(TIUDA)
I DATA'="" D
.S IDX=$G(IDX)+1
.I $G(INTIUY) S TIUY(IDX)=DATA
.E S ^TMP("TIU TEMPLATE",$J,IDX)=DATA
Q
CPACT(RET,DFN,PRIEN,CPTYP,NUM) ;EP
; DFN = The patient this problem belongs to
; PRIEN= The problem to return care planning data on
; CPTYP= A All
; C Active
; L Last date
; NUM = Number of entries in V files to return
; RET = Array of care planning items for a problem
N CNT
I CPTYP="" S CPTYP="L"
;For Visit instructions and treatments, the default is the latest visit
I $G(NUM)="" S NUM=1
S RET=$$TMPGBL^BGOUTL
S CNT=0
D GET^BGOCPLAN(.RET,PRIEN,DFN,"G",CPTYP,.CNT)
D GET^BGOCPLAN(.RET,PRIEN,DFN,"P",CPTYP,.CNT)
D GET^BGOVVI(.RET,DFN,PRIEN,NUM,.CNT)
D GET^BGOVTR(.RET,DFN,PRIEN,NUM,.CNT)
D GETCON^BGOVTR(.RET,DFN,PRIEN,NUM,.CNT)
Q
SCRN(Y,ENT) ;Return only items in shared templates
N ITM,SEQ,ITEM,ITEMNODE,RET,PROV
S RET=0
S ITM=$O(^TIU(8927,"B","Shared Templates",""))
D LOOP
I $P(ENT,";",2)="VA(200," D
. S PROV=$P(ENT,";",1)
. S ITM=$O(^TIU(8927,"AROOT",PROV,""))
. D LOOP
Q RET
LOOP N TYPE
I $P($G(^TIU(8927,ITM,0)),U,3)'="T" D
.S (IDX,SEQ)=0
.F S SEQ=$O(^TIU(8927,ITM,10,"B",SEQ)) Q:'SEQ D
..S ITEM=0
..F S ITEM=$O(^TIU(8927,ITM,10,"B",SEQ,ITEM)) Q:'ITEM D
...S ITEMNODE=$G(^TIU(8927,ITM,10,ITEM,0))
...I $P(ITEMNODE,U,2)=Y D
....S TYPE=$P($G(^TIU(8927,$P(ITEMNODE,U,2),0)),U,3)
....S RET=$S(TYPE="T":1,TYPE="G":1,1:0)
Q
BGOCPLAN ; IHS/BAO/TMD - pull V Care Plan data ;27-Jan-2016 09:53;DU
+1 ;;1.1;BGO COMPONENTS;**13,14,17,19**;Mar 20, 2007;Build 5
+2 ;P14 changed to return time when entered
+3 ;---------------------------------------------
GET(DATA,IEN,DFN,TYPE,RETI,CNT,PRV) ;EP
+1 ;Find the latest number of entries for each section using the
+2 ;parameter and return them to the calling program
+3 ;Input is IEN = Problem
+4 ; DFN = Patient
+5 ; TYPE = G(oal) or C(are Plan)
+6 ; RETI = Return types (A(active),C(complete),L(latest)
+7 ; CNT = Count
+8 ; PRV = Provider to look for data on
+9 ;Ouput: Array in the format
+10 ;Array(n)=Type (G OR C) [1] ^ C Plan IEN [2] ^ Prob IEN [4] ^ Who entered [4] ^ Date Entered [5] ^ Status [6] ^ SIGN FLAG [7]
+11 ; =~t [1] ^ Text of the item [2]
+12 NEW GCNT,INVDT,NODE,FNUM,CODE,DONE,STA,STAT,SDATE,CPIEN,SIEN,SORT
+13 SET DONE=0
SET SDATE=0
+14 IF $GET(RETI)=""
SET RETI="L"
+15 IF $GET(DATA)=""
SET DATA=$$TMPGBL
+16 IF $GET(CNT)=""
SET CNT=1
+17 SET PRV=$GET(PRV)
+18 IF RETI=""
SET RETI="L"
+19 SET INVDT=""
+20 SET TYPE=$SELECT(TYPE="C":"P",1:TYPE)
+21 IF PRV'=""
Begin DoDot:1
+22 FOR
SET INVDT=$ORDER(^AUPNCPL("APTP",IEN,TYPE,PRV,INVDT))
IF INVDT=""!(DONE=1)
QUIT
Begin DoDot:2
+23 SET CPIEN=""
FOR
SET CPIEN=$ORDER(^AUPNCPL("APTP",IEN,TYPE,PRV,INVDT,CPIEN))
IF CPIEN=""
QUIT
Begin DoDot:3
+24 SET SIEN=$CHAR(0)
SET SIEN=$ORDER(^AUPNCPL(CPIEN,11,SIEN),-1)
+25 SET STATUS=$PIECE($GET(^AUPNCPL(CPIEN,11,SIEN,0)),U,1)
+26 IF STATUS="E"
QUIT
+27 IF (STATUS="R")&(RETI'="C")
QUIT
+28 SET SORT(INVDT,CPIEN,SIEN)=""
+29 ;D DATA(.DATA,CPIEN,SIEN)
End DoDot:3
End DoDot:2
+30 DO DATA(.DATA,.SORT)
End DoDot:1
+31 IF PRV=""
Begin DoDot:1
+32 SET CPIEN=""
FOR
SET CPIEN=$ORDER(^AUPNCPL("APT",IEN,TYPE,CPIEN))
IF CPIEN=""!(DONE=1)
QUIT
Begin DoDot:2
+33 SET SIEN=$CHAR(0)
SET SIEN=$ORDER(^AUPNCPL(CPIEN,11,SIEN),-1)
+34 SET STATUS=$PIECE($GET(^AUPNCPL(CPIEN,11,SIEN,0)),U,1)
+35 IF STATUS="E"
QUIT
+36 IF (STATUS="R")&(RETI'="C")
QUIT
+37 ;D DATA(.DATA,CPIEN,SIEN)
+38 SET INVDT=9999999-$PIECE($GET(^AUPNCPL(CPIEN,0)),U,5)
+39 SET SORT(INVDT,CPIEN,SIEN)=""
End DoDot:2
+40 DO DATA(.DATA,.SORT)
End DoDot:1
+41 QUIT
IEN(DATA) ;FIND IEN
+1 IF STATUS="E"
QUIT
+2 IF RETI="C"!(STATUS="A"&((RETI="A")!(RETI="L")))
Begin DoDot:1
+3 SET CPIEN=""
SET CPIEN=$ORDER(^AUPNCPL("ASDT",IEN,TYPE,INVDT,STATUS,CPIEN))
IF CPIEN=""
QUIT
Begin DoDot:2
+4 SET SIEN=""
FOR
SET SIEN=$ORDER(^AUPNCPL("ASDT",IEN,TYPE,INVDT,STATUS,CPIEN,SIEN),-1)
IF SIEN=""
QUIT
Begin DoDot:3
End DoDot:3
+5 SET SORT(INVDT,CPIEN,SIEN)=""
End DoDot:2
+6 DO DATA(.DATA,.SORT)
End DoDot:1
+7 QUIT
DATA(DATA,SORT) ;Get data for this item
+1 NEW INVDT,CPIEN,SIEN
+2 SET INVDT=""
FOR
SET INVDT=$ORDER(SORT(INVDT))
IF INVDT=""
QUIT
Begin DoDot:1
+3 SET CPIEN=""
FOR
SET CPIEN=$ORDER(SORT(INVDT,CPIEN))
IF CPIEN=""
QUIT
Begin DoDot:2
+4 SET SIEN=""
FOR
SET SIEN=$ORDER(SORT(INVDT,CPIEN,SIEN))
IF SIEN=""
QUIT
Begin DoDot:3
+5 DO DATA1(.DATA,CPIEN,SIEN)
End DoDot:3
End DoDot:2
End DoDot:1
+6 QUIT
DATA1(DATA,CPIEN,SIEN) ;Get data for one plan
+1 NEW BY,WHEN,LIEN,TXT,TXTIEN,PTYPE,SIGNED,PROB,SIG
+2 SET FNUM=9000092.11
+3 SET SIGNED=0
+4 SET SIGNED=$PIECE($GET(^AUPNCPL(CPIEN,0)),U,7)
+5 ;Q:(SIGNED="")&(DUZ'=$$GET1^DIQ(9000092,CPIEN,.03,"I")) ;DKA 9/9/13 Don't filter out
+6 SET NODE=$GET(^AUPNCPL(CPIEN,11,SIEN,0))
+7 IF SDATE=0
SET SDATE=$PIECE(INVDT,".",1)
+8 IF RETI="L"&(SDATE'=$PIECE(INVDT,".",1))
SET DONE=1
+9 IF +DONE
QUIT
+10 SET CNT=CNT+1
+11 SET LIEN=SIEN_","_CPIEN
+12 SET WHEN=$$GET1^DIQ(FNUM,LIEN,.03,"I")
+13 SET WHEN=$$FMTDATE^BGOUTL(WHEN,1)
+14 SET BY=$$GET1^DIQ(FNUM,LIEN,.02,"E")
+15 SET STAT=$$GET1^DIQ(FNUM,LIEN,.01,"I")
+16 SET PTYPE=$SELECT(TYPE="P":"C",1:"G")
+17 SET SIG=$$GET1^DIQ(9000092,CPIEN,.08,"I")
+18 IF SIG'=""
SET SIG=$$FMTDATE^BGOUTL(SIG)
+19 ;S @DATA@(CNT)=PTYPE_U_CPIEN_U_IEN_U_BY_U_WHEN_U_STAT_U_SIGNED
+20 SET @DATA@(CNT)=PTYPE_U_CPIEN_U_IEN_U_BY_U_WHEN_U_STAT_U_SIG
+21 SET TXTIEN=0
FOR
SET TXTIEN=$ORDER(^AUPNCPL(CPIEN,12,TXTIEN))
IF '+TXTIEN
QUIT
Begin DoDot:1
+22 SET CNT=CNT+1
+23 ;IHS/MSC/MGH changed for carriage returns P17
+24 SET @DATA@(CNT)="~t"_U_$TRANSLATE($GET(^AUPNCPL(CPIEN,12,TXTIEN,0)),$CHAR(13,10))
End DoDot:1
+25 QUIT
+26 QUIT
+27 ; Input Variables
+28 ; DFN = Patient
+29 ; PRIEN = problem this plan belongs to
+30 ; INP = G(goal) or P(Care plan)[1] ^ IEN [2] (blank if new) ^ EDT(event dt/time) [3] ^ Provider [4]
+31 ; STATUS = SIEN [1] ^ STATUS [2] ^ WHO ENTERED [3] ^ WHEN [4] ^ Old Item if replaced [5] ^ REASON EIE [6]^ REASON IF OTHER [7] ^ Comment [8]
+32 ; TEXT(n) = Text of the item
SET(RET,DFN,PRIEN,INP,STATUS,TEXT) ;EP
+1 NEW FDA,IEN,FPNUM,CIEN,FNUM,IENS,PRNEW,PRIOR,SNOCT,DESCT,X,PIEN
+2 NEW TYP,IEN,EDT,PRV,OLD,SIEN,WHO,WHEN,STAT,OLDIEN,NEWIEN,STAT2,X2
+3 SET FNUM=$$FNUM
SET RET=""
SET ERR=0
SET OLD=""
+4 IF $GET(PRIEN)=""
SET RET="1^No Problem was input and care planning cannot be saved"
QUIT
+5 SET TYP=$SELECT($PIECE(INP,U,1)="C":"P",1:$PIECE(INP,U,1))
+6 SET IEN=$PIECE(INP,U,2)
SET EDT=$PIECE(INP,U,3)
SET PRV=$PIECE(INP,U,4)
+7 ;IHS/MSC/MGH Fix for sending in a zero
+8 IF IEN=0
SET IEN=""
+9 IF TYP=""
SET RET="1^A Care Planning type was not entered. Cannot save item"
QUIT
+10 SET STAT=$PIECE(STATUS,U,2)
+11 IF STAT=""
SET RET="1^No status was entered and care planning cannot be saved"
QUIT
+12 IF IEN=""
SET CIEN="+1,"
+13 IF '$TEST
SET CIEN=IEN_","
+14 IF EDT=""
SET EDT=$$NOW^XLFDT
+15 IF PRV=""
SET PRV=DUZ
+16 IF $PIECE(STATUS,U,4)'=""
SET OLD=$PIECE(STATUS,U,5)
+17 SET FDA=$NAME(FDA(FNUM,CIEN))
+18 SET @FDA@(.01)=PRIEN
+19 SET @FDA@(.02)=DFN
+20 SET @FDA@(.03)=PRV
+21 SET @FDA@(.04)=TYP
+22 SET @FDA@(.05)=EDT
+23 SET @FDA@(.06)=$$NOW^XLFDT
+24 IF OLD'=""
SET @FDA@(.09)=OLD
+25 SET RET=$$UPDATE^BGOUTL(.FDA,,.PIEN)
+26 IF RET
QUIT
+27 IF 'IEN
SET IEN=PIEN(1)
+28 IF 'RET
SET RET=IEN
+29 ;Add in the status multiple if it hasn't changed
+30 SET SIEN=$PIECE(STATUS,U,1)
+31 SET X2=$CHAR(0)
+32 ;Find the latest status
+33 SET X2=$ORDER(^AUPNCPL(IEN,11,X2),-1)
+34 IF X2'=""
Begin DoDot:1
+35 SET STAT2=$PIECE($GET(^AUPNCPL(IEN,11,X2,0)),U,1)
+36 ;Add new entry if status changed
IF STAT'=STAT2
SET SIEN=""
+37 IF '$TEST
SET SIEN=X2
End DoDot:1
+38 SET WHO=$PIECE(STATUS,U,3)
+39 SET WHEN=$PIECE(STATUS,U,4)
+40 IF WHO=""
SET WHO=DUZ
+41 IF WHEN=""
SET WHEN=$$NOW^XLFDT
+42 IF SIEN=""
SET SIEN="+1,"_IEN_","
+43 IF '$TEST
SET SIEN=SIEN_","_IEN_","
+44 NEW FDA,ERR,IEN2
+45 SET FDA(9000092.11,SIEN,.01)=STAT
+46 SET FDA(9000092.11,SIEN,.02)=WHO
+47 SET FDA(9000092.11,SIEN,.03)=WHEN
+48 SET FDA(9000092.11,SIEN,1)=$PIECE(STATUS,U,8)
+49 IF STAT="E"!(STAT="ENTERED IN ERROR")
Begin DoDot:1
+50 SET FDA(9000092.11,SIEN,.04)=$PIECE(STATUS,U,6)
+51 SET FDA(9000091.11,SIEN,.05)=$PIECE(STATUS,U,7)
End DoDot:1
+52 DO UPDATE^DIE(,"FDA","IEN2","ERR")
+53 IF $GET(ERR("DIERR",1))
SET RET=-ERR("DIERR",1)_U_ERR("DIERR",1,"TEXT",1)
QUIT
+54 ;Add in the text of the item if its not signed
+55 IF $$GET1^DIQ(9000092,IEN,.07)=""
Begin DoDot:1
+56 NEW TXT,TCNT,I
+57 SET TCNT=0
+58 SET I=""
FOR
SET I=$ORDER(TEXT(I))
IF I=""
QUIT
Begin DoDot:2
+59 SET TCNT=TCNT+1
+60 SET TXT(TCNT,0)=$GET(TEXT(I))
End DoDot:2
+61 DO WP^DIE(9000092,IEN_",",1200,,"TXT")
End DoDot:1
+62 ;if replaced update original
+63 IF +OLD
DO UPDATE(OLD)
+64 QUIT
UPDATE(OLD) ;Update data
+1 NEW OLDIEN,FDA,ERR,IEN2
+2 SET OLDIEN="+1,"_OLD_","
+3 SET FDA=$NAME(FDA(FNUM,OLDIEN))
+4 SET FDA(9000092.11,OLDIEN,.01)="R"
+5 SET FDA(9000092.11,OLDIEN,.02)=WHO
+6 SET FDA(9000092.11,OLDIEN,.03)=WHEN
+7 SET FDA(9000092.11,OLDIEN,.06)=IEN
+8 DO UPDATE^DIE(,"FDA","IEN2","ERR")
+9 QUIT
LOOK(SNOMED) ;Lookup snomed term
+1 NEW RET
+2 SET RET=$PIECE($$DESC^BSTSAPI(SNOMED_"^^1"),U,2)
+3 QUIT RET
+4 ;Sign the plan
+5 ;Input=IEN of the entry
+6 ;Provider who is signing
SIGN(RET,IEN,PRV) ;Sign the entry
+1 NEW FNUM,FDA,IEN2,ERR,AIEN
+2 SET RET=""
SET ERR=""
+3 SET AIEN=IEN_","
+4 SET FDA(9000092,AIEN,.07)=PRV
+5 SET FDA(9000092,AIEN,.08)=$$NOW^XLFDT
+6 DO FILE^DIE("","FDA","ERR")
+7 IF ERR
SET RET=-1_U_"Unable to sign Care Plan"
+8 QUIT
+9 ; Delete a Care Plan entry
DEL(RET,PLAN) ;EP
+1 NEW GBL
+2 IF $GET(PLAN)=""
SET RET="-1^Care Plan number not entered"
QUIT
+3 IF $$GET1^DIQ(9000092,PLAN,.07)'=""
SET RET="-1^Already signed"
QUIT
+4 SET GBL=$$ROOT^DILFD($$FNUM,,1)
SET RET=""
+5 SET FNUM=$$FNUM^BGOCPLAN
+6 IF 'PLAN
QUIT
+7 IF '$LENGTH(GBL)
SET RET=$$ERR^BGOUTL(1069)
QUIT
+8 SET RET=$$DELETE^BGOUTL(FNUM,PLAN)
+9 IF 'RET
DO VFEVT^BGOUTL2(FNUM,PLAN,2,X)
+10 QUIT
UPSTAT(RET,IEN,PROB,STAT,COMM) ;Change the status of a care plan or goal
+1 NEW AIEN,FDA,ERR,SIEN,IEN2
+2 SET RET=""
+3 SET SIEN="+1,"_IEN_","
+4 SET FDA(9000092.11,SIEN,.01)=STAT
+5 SET FDA(9000092.11,SIEN,.02)=DUZ
+6 SET FDA(9000092.11,SIEN,.03)=$$NOW^XLFDT
+7 ;S FDA(9000092.11,SIEN,1)=COMM
+8 ;2013-09-10 DKA P13 Allow blank comment
IF $GET(COMM)'=""
SET FDA(9000092.11,SIEN,1)=COMM
+9 DO UPDATE^DIE(,"FDA","IEN2","ERR")
+10 IF $DATA(ERR)>0
SET RET="-1^Unable to update status"
+11 QUIT
+12 ;Input parameter
+13 ;INP= Problem ien [1] ^ Reason for eie [2] ^ comment if other [3]
EIE(RET,INP) ;Mark an entry entered in error
+1 NEW FNUM,IEN2,FDA,IEN,REASON,CMMT,IENS,RET
+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 FNUM=9000092.11
+7 SET IEN2="+1,"_IENS_","
+8 SET FDA=$NAME(FDA(FNUM,IEN2))
+9 SET @FDA@(.01)="E"
+10 SET @FDA@(.02)=DUZ
+11 SET @FDA@(.03)=$$NOW^XLFDT()
+12 SET @FDA@(.04)=REASON
+13 SET @FDA@(.04)=CMMT
+14 SET RET=$$UPDATE^BGOUTL(.FDA,,.IEN)
+15 QUIT
+16 ;EIE can only be done by the author or the chief of MIS
+17 ;Input = IEN of the entry [1] ^ user deleting [2]
OKDEL(RET,IEN,USER) ;EP Can this user delete
+1 NEW PRV,ENTRYDT,ERR
+2 SET RET=0
+3 IF $GET(USER)=""
SET USER=DUZ
+4 SET PRV=$$GET1^DIQ(9000092,IEN,.03,"I")
+5 IF PRV=USER
SET RET=1
QUIT
+6 SET ENTRYDT=$$NOW^XLFDT
+7 SET ERR=""
+8 SET RET=$$ISA^TIUPS139(USER,"CHIEF, MIS",ERR)
+9 QUIT
PAR(INP) QUIT $SELECT($$GET^XPAR("SYS","BEH PARAMETER",INP)>0:$$GET^XPAR("SYS","BEH PARAMETER",INP),1:1)
TMPGBL(X) ;EP
+1 KILL ^TMP("BGOPLAN"_$GET(X),$JOB)
QUIT $NAME(^($JOB))
+2 ; Return file number
FNUM() QUIT 9000092
+1 ; Use parameters to get and load TIU templates into the care plan
+2 ; Nodes Returned by GETITEMS
+3 ;
+4 ; Piece Data
+5 ; ----- ---------------------
+6 ; 1 IEN
+7 ; 2 TYPE
+8 ; 3 STATUS
+9 ; 4 NAME
+10 ; 5 EXCLUDE FROM GROUP BOILERPLATE
+11 ; 6 BLANK LINES
+12 ; 7 PERSONAL OWNER
+13 ; 8 HAS CHILDREN FLAG (0=NONE, 1=ACTIVE, 2=INACTIVE, 3=BOTH)
+14 ; 9 DIALOG
+15 ; 10 DISPLAY ONLY
+16 ; 11 FIRST LINE
+17 ; 12 ONE ITEM ONLY
+18 ; 13 HIDE DIALOG ITEMS
+19 ; 14 HIDE TREE ITEMS
+20 ; 15 INDENT ITEMS
+21 ; 16 REMINDER DIALOG IEN
+22 ; 17 REMINDER DIALOG NAME
+23 ; 18 LOCKED
+24 ; 19 COM OBJECT POINTER
+25 ; 20 COM OBJECT PARAMETER
+26 ; 21 LINK POINTER
GETROOTS(TIUY,USER,PARAM) ;Get template root info
+1 NEW IDX,TIUDA,TYPE,PARAM,ENT,ARY,ERR,LP
+2 SET ENT=$$ENT^CIAVMRPC(PARAM,.ENT)
+3 DO GETLST^XPAR(.ARY,ENT,PARAM,"N",.ERR)
+4 IF $GET(ERR)
KILL ARY
SET DATA=ERR
+5 SET LP=0
FOR
SET LP=$ORDER(ARY(LP))
IF LP<1
QUIT
Begin DoDot:1
+6 SET TIUDA=$PIECE(ARY(LP),U,1)
+7 DO ADDNODE(.IDX,TIUDA,1)
End DoDot:1
+8 QUIT
ADDNODE(IDX,TIUDA,INTIUY) ;Adds template node info
+1 NEW DATA
+2 SET DATA=$$NODEDATA^TIUSRVT(TIUDA)
+3 IF DATA'=""
Begin DoDot:1
+4 SET IDX=$GET(IDX)+1
+5 IF $GET(INTIUY)
SET TIUY(IDX)=DATA
+6 IF '$TEST
SET ^TMP("TIU TEMPLATE",$JOB,IDX)=DATA
End DoDot:1
+7 QUIT
CPACT(RET,DFN,PRIEN,CPTYP,NUM) ;EP
+1 ; DFN = The patient this problem belongs to
+2 ; PRIEN= The problem to return care planning data on
+3 ; CPTYP= A All
+4 ; C Active
+5 ; L Last date
+6 ; NUM = Number of entries in V files to return
+7 ; RET = Array of care planning items for a problem
+8 NEW CNT
+9 IF CPTYP=""
SET CPTYP="L"
+10 ;For Visit instructions and treatments, the default is the latest visit
+11 IF $GET(NUM)=""
SET NUM=1
+12 SET RET=$$TMPGBL^BGOUTL
+13 SET CNT=0
+14 DO GET^BGOCPLAN(.RET,PRIEN,DFN,"G",CPTYP,.CNT)
+15 DO GET^BGOCPLAN(.RET,PRIEN,DFN,"P",CPTYP,.CNT)
+16 DO GET^BGOVVI(.RET,DFN,PRIEN,NUM,.CNT)
+17 DO GET^BGOVTR(.RET,DFN,PRIEN,NUM,.CNT)
+18 DO GETCON^BGOVTR(.RET,DFN,PRIEN,NUM,.CNT)
+19 QUIT
SCRN(Y,ENT) ;Return only items in shared templates
+1 NEW ITM,SEQ,ITEM,ITEMNODE,RET,PROV
+2 SET RET=0
+3 SET ITM=$ORDER(^TIU(8927,"B","Shared Templates",""))
+4 DO LOOP
+5 IF $PIECE(ENT,";",2)="VA(200,"
Begin DoDot:1
+6 SET PROV=$PIECE(ENT,";",1)
+7 SET ITM=$ORDER(^TIU(8927,"AROOT",PROV,""))
+8 DO LOOP
End DoDot:1
+9 QUIT RET
LOOP NEW TYPE
+1 IF $PIECE($GET(^TIU(8927,ITM,0)),U,3)'="T"
Begin DoDot:1
+2 SET (IDX,SEQ)=0
+3 FOR
SET SEQ=$ORDER(^TIU(8927,ITM,10,"B",SEQ))
IF 'SEQ
QUIT
Begin DoDot:2
+4 SET ITEM=0
+5 FOR
SET ITEM=$ORDER(^TIU(8927,ITM,10,"B",SEQ,ITEM))
IF 'ITEM
QUIT
Begin DoDot:3
+6 SET ITEMNODE=$GET(^TIU(8927,ITM,10,ITEM,0))
+7 IF $PIECE(ITEMNODE,U,2)=Y
Begin DoDot:4
+8 SET TYPE=$PIECE($GET(^TIU(8927,$PIECE(ITEMNODE,U,2),0)),U,3)
+9 SET RET=$SELECT(TYPE="T":1,TYPE="G":1,1:0)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
