ORAM1 ;POR/RSF - ANTICOAGULATION MANAGEMENT RPCS (2 of 4) ; 3/23/18 3:14pm
;;3.0;ORDER ENTRY/RESULTS REPORTING;**307,339,351,361,391,474,463**;Dec 17, 1997;Build 5
;;Per VHA Directive 2004-038, this routine should not be modified
Q
;
; External References:
; $$EXTERNAL^DILFD ICR #2055
; $$FMTE/$$NOW^XLFDT ICR #10103
; $$GET^XPAR ICR #2263
;
TERASE(RESULT,ORAMDFN,ORAMCOMP) ; Manage Team Lists
N ORAMKEY,ORAMTMP,ORAMCEY,ORAMCLIN,ORAMCLNM,ORAMCOM,ORAMALL,ORAMCPLX,ORAMENT,QQ,DA,DIK,D0
Q:'+$G(ORAMDFN)
S ORAMCLIN=+$P($G(^ORAM(103,ORAMDFN,6)),U,2),ORAMENT=$S(+ORAMCLIN>0:ORAMCLIN_";SC(",1:"ALL")
I +ORAMCLIN S ORAMCLNM=$$EXTERNAL^DILFD(103,101,"",ORAMCLIN)
S ORAMALL=$$GET^XPAR(ORAMENT,"ORAM TEAM LIST (ALL)",1,"I"),ORAMCPLX=$$GET^XPAR(ORAMENT,"ORAM TEAM LIST (COMPLEX)",1,"I")
I +$G(ORAMALL) D I 1
. S DA(1)=ORAMALL,DIK="^OR(100.21"_","_DA(1)_",10,"
. S ORAMTMP=ORAMDFN_";DPT("
. S ORAMKEY=$O(^OR(100.21,ORAMALL,10,"B",ORAMTMP,0)) Q:+ORAMKEY'>0 S DA=ORAMKEY
. D ^DIK
. K DA,DIK
. K D0
. S RESULT=1
E S RESULT="0^ORAM TEAM LIST (ALL) not defined for Clinic "_ORAMCLNM_"."
I +$G(ORAMCPLX) D I 1
. S DA(1)=ORAMCPLX,DIK="^OR(100.21"_","_DA(1)_",10,"
. S ORAMCEY=$O(^OR(100.21,ORAMCPLX,10,"B",ORAMTMP,0)) Q:+ORAMCEY'>0 S DA=ORAMCEY
. D ^DIK
. K DA,DIK
. S:'$D(RESULT) RESULT=1
E S RESULT="0^ORAM TEAM LIST (COMPLEX) not defined for Clinic "_ORAMCLNM_"."
Q
;
;ICDCODE(RESULT,ICODE); Map ICD Code //REMOVED BECAUSE OF DIRECT READ OF ^ICD9( FILE
;N ORAMICD
;S ORAMICD=ICODE_" "
;S RESULT=$O(^ICD9("AB",ORAMICD,0))
;Q
;
PTCHECK(RESULT,ORAMDFN) ; CHECKS TO SEE IF PT IS IN FILE
N ORPTLOC
Q:'+$G(ORAMDFN)
S RESULT=0
I $S('$D(^ORAM(103,ORAMDFN)):1,+$O(^ORAM(103,ORAMDFN,3,0))'>0:1,1:0) S RESULT=1 Q
S ORPTLOC=$P($G(^ORAM(103,ORAMDFN,6)),U,2)
I ORPTLOC']"" S RESULT=2 Q
I +ORPTLOC,'$L($$GET^XPAR(ORPTLOC_";SC(^DIV.`"_DUZ(2),"ORAM CLINIC NAME",1,"I")) S RESULT=99
Q
;
PTENTER(RESULT,DFN) ; ENTERS PATIENT INTO FILE WITH ALL DATES = TODAY
N DO,DD,DIC,DINUM,X
S DIC="^ORAM(103,"
S DIC(0)="Z"
S (DINUM,X)=DFN
D FILE^DICN
K DO,DD
S RESULT=1
Q
;
ACDATA(RESULT,DFN,ORAMEDT) ; HEADING DATA
N ORAMSTOT,ORAMRTOT,ORAMRAT,ORAMMSGT,ORAMRAT,ORAMBRT,ORAMX,ORI,ORLINE
N ORAMD0,ORAMD4,ORAMD5,ORAMD6,ORAMD9,ORAMD15,ORAMD17,ORAMD18
N ORAMT4,ORAMT5,ORAMT6,ORAMT9,ORAMT15,ORAMT17,ORAMT18,ORAMDXT,ORAMDXC,ORDXI,ORAMPOP
S ORAMEDT=$G(ORAMEDT,DT)
S ORAMX=0
I '$D(^ORAM(103,DFN)) D ;IF NOT IN FILE ALREADY...
. N DD,DIC,DINUM,DO,X
. S DIC="^ORAM(103,"
. S DIC(0)="Z"
. S (DINUM,X)=DFN
. D FILE^DICN
. K DO,DD
. S ORAMX=1
I ORAMX=1 S RESULT(0)=0 G ACDATAQ
S ORAMD0=^ORAM(103,DFN,0)
S ORI=0 F S ORI=$O(^ORAM(103,DFN,1,ORI)) Q:+ORI'>0 S ORLINE=$G(^ORAM(103,DFN,1,ORI,0)) S:ORLINE="" ORLINE=" " S ORAMSTOT=$G(ORAMSTOT)_U_ORLINE
S ORI=0 F S ORI=$O(^ORAM(103,DFN,2,ORI)) Q:+ORI'>0 S ORLINE=$G(^ORAM(103,DFN,2,ORI,0)) S:ORLINE="" ORLINE=" " S ORAMRTOT=$G(ORAMRTOT)_U_ORLINE
S ORI=0 F S ORI=$O(^ORAM(103,DFN,4,ORI)) Q:+ORI'>0 S ORLINE=$G(^ORAM(103,DFN,4,ORI,0)) S:ORLINE="" ORLINE=" " S ORAMMSGT=$G(ORAMMSGT)_U_ORLINE
S ORI=0 F S ORI=$O(^ORAM(103,DFN,5,ORI)) Q:+ORI'>0 S ORLINE=$G(^ORAM(103,DFN,5,ORI,0)) S:ORLINE="" ORLINE=" " S ORAMRAT=$G(ORAMRAT)_U_ORLINE
S ORI=0 F S ORI=$O(^ORAM(103,DFN,7,ORI)) Q:+ORI'>0 S ORLINE=$G(^ORAM(103,DFN,7,ORI,0)) S:ORLINE="" ORLINE=" " S ORAMBRT=$G(ORAMBRT)_U_ORLINE
S RESULT(0)=$G(ORAMSTOT)
S RESULT(1)=$G(ORAMRTOT)
S RESULT(2)=$G(ORAMMSGT)
S RESULT(4)=$G(ORAMRAT)
S RESULT(5)=$S($G(ORAMBRT)]"":$P($G(^ORAM(103,DFN,6)),"^",5)_"^"_$P($G(ORAMBRT),"^",2,99),1:"")
S ORAMD4=$P(ORAMD0,"^",4),ORAMD5=$P(ORAMD0,"^",5),ORAMD6=$P(ORAMD0,"^",6),ORAMD9=$P(ORAMD0,"^",9),ORAMD15=$P(ORAMD0,"^",15),ORAMD17=$P(ORAMD0,"^",17),ORAMD18=$P(ORAMD0,"^",18)
S ORAMT4=$$FMTE^XLFDT($E($G(ORAMD4),1,12),"2P"),ORAMT5=$$FMTE^XLFDT($E($G(ORAMD5),1,12),"2P"),ORAMT6=$$FMTE^XLFDT($E($G(ORAMD6),1,12),"2P"),ORAMT9=$$FMTE^XLFDT($E($G(ORAMD9),1,12),"2P")
S ORAMT15=$$FMTE^XLFDT($E($G(ORAMD15),1,12),"2P"),ORAMT17=$$FMTE^XLFDT($E($G(ORAMD17),1,12),"2P"),ORAMT18=$$FMTE^XLFDT($E($G(ORAMD18),1,12),"2P")
S:$L($P(ORAMT4,"/",1))=1 $P(ORAMT4,"/",1)="0"_$P(ORAMT4,"/",1)
S:$L($P(ORAMT4,"/",2))=1 $P(ORAMT4,"/",2)="0"_$P(ORAMT4,"/",2)
S:$L($P(ORAMT15,"/",1))=1 $P(ORAMT15,"/",1)="0"_$P(ORAMT15,"/",1)
S:$L($P(ORAMT15,"/",2))=1 $P(ORAMT15,"/",2)="0"_$P(ORAMT15,"/",2)
S:$L($P(ORAMT17,"/",1))=1 $P(ORAMT17,"/",1)="0"_$P(ORAMT17,"/",1)
S:$L($P(ORAMT17,"/",2))=1 $P(ORAMT17,"/",2)="0"_$P(ORAMT17,"/",2)
S:$L($P(ORAMT18,"/",1))=1 $P(ORAMT18,"/",1)="0"_$P(ORAMT18,"/",1)
S:$L($P(ORAMT18,"/",2))=1 $P(ORAMT18,"/",2)="0"_$P(ORAMT18,"/",2)
; OR*3*391 Check validity of legacy Dx code
S ORAMDXT=$P($P(ORAMD0,U,3),"="),ORAMDXC=$P($P(ORAMD0,U,3),"=",2),ORAMPOP=0
F ORDXI=1:1:$L(ORAMDXC,"/") D Q:+ORAMPOP
. N ORDXC,ORDX S ORDXC=$P(ORAMDXC,"/",ORDXI)
. I (ORDXC]""),(ORDXC'[".") S ORDXC=ORDXC_"."
. S ORDX=+$$ICDDATA^ICDXCODE("DIAGNOSIS",ORDXC,ORAMEDT,"E")
. I +ORDX'>0 S ORAMDXC=""
S $P(ORAMD0,U,3)=ORAMDXT_"="_ORAMDXC
S $P(ORAMD0,"^",4)=$G(ORAMT4),$P(ORAMD0,"^",5)=$G(ORAMT5),$P(ORAMD0,"^",6)=$G(ORAMT6),$P(ORAMD0,"^",9)=$G(ORAMT9),$P(ORAMD0,"^",15)=$G(ORAMT15),$P(ORAMD0,"^",17)=$G(ORAMT17),$P(ORAMD0,"^",18)=$G(ORAMT18)
S RESULT(3)=ORAMD0 S:$D(^ORAM(103,DFN,6)) RESULT(3)=RESULT(3)_"^"_$P(^ORAM(103,DFN,6),"^")
ACDATAQ Q
;
ADDTOP(RESULT,TOPARR) ; File ANTICOAG data
N ORAM0,SI,RISK,PEEP,ORAMSIL,ORAMRL,ORAMPEPL,ORAMDAY,ORAMST,ORAMBACK,ORAMSTP,ORAMOR,ORAMFB,ORAMREM,ORAMRML,ORAMR,ORAMC
N ORAMBRG,ORAMBRGC,ORAMBRGL,ORAMLOC,OLDRTN,DFN,R,X,FDA
D NOW^%DTC S ORAMDAY=X
S DFN=TOPARR(0),ORAM0=TOPARR(1),SI=TOPARR(2),RISK=TOPARR(3),PEEP=TOPARR(4),ORAMREM=TOPARR(5)
S ORAMBRG=$G(TOPARR(6)),ORAMBRGC=$G(TOPARR(7)),ORAMLOC=$G(TOPARR(8))
S OLDRTN=$P($G(^ORAM(103,DFN,0)),"^",4)
I SI'="" K ^ORAM(103,DFN,1) S ORAMSIL=$L(SI,"^"),^ORAM(103,DFN,1,0)="^^"_ORAMSIL_"^"_ORAMSIL_"^"_ORAMDAY_"^" F R=1:1:ORAMSIL D
. S ^ORAM(103,DFN,1,R,0)=$P(SI,"^",R)
I RISK'="" K ^ORAM(103,DFN,2) S ORAMRL=$L(RISK,"^"),^ORAM(103,DFN,2,0)="^^"_ORAMRL_"^"_ORAMRL_"^"_ORAMDAY_"^" F R=1:1:ORAMRL D
. S ^ORAM(103,DFN,2,R,0)=$P(RISK,"^",R)
I PEEP'="" K ^ORAM(103,DFN,4) S ORAMPEPL=$L(PEEP,"^"),^ORAM(103,DFN,4,0)="^^"_ORAMPEPL_"^"_ORAMPEPL_"^"_ORAMDAY_"^" F R=1:1:ORAMPEPL D
. S ^ORAM(103,DFN,4,R,0)=$P(PEEP,"^",R)
K ^ORAM(103,DFN,5)
I ORAMREM'="" D
. S ORAMRML=$L(ORAMREM,"^"),^ORAM(103,DFN,5,0)="^^"_ORAMRML_"^"_ORAMRML_"^"_ORAMDAY_"^"
. F R=1:1:ORAMRML S ^ORAM(103,DFN,5,R,0)=$P(ORAMREM,"^",R)
;*351 Use Fileman so x-ref updates.
S:ORAMLOC>0 FDA(1,103,DFN_",",101)=ORAMLOC
S FDA(1,103,DFN_",",111)=+ORAMBRG
D UPDATE^DIE(,"FDA(1)")
I +ORAMBRG,(ORAMBRGC]"") D
. K ^ORAM(103,DFN,7)
. S ORAMBRGL=$L(ORAMBRGC,"^"),^ORAM(103,DFN,7,0)="^^"_ORAMBRGL_"^"_ORAMBRGL_"^"_ORAMDAY_"^"
. F R=1:1:ORAMBRGL S ^ORAM(103,DFN,7,R,0)=$P(ORAMBRGC,"^",R)
I $P($G(ORAM0),"^",4)'="" S X="",ORAMBACK=$P(ORAM0,"^",4) D DT^DILF("TS",ORAMBACK,.X) S $P(ORAM0,"^",4)=X
I $P($G(ORAM0),"^",15)'="" S X="",ORAMFB=$P(ORAM0,"^",15) D DT^DILF(,ORAMFB,.X) S $P(ORAM0,"^",15)=X
I $P($G(ORAM0),"^",17)'="" S X="",ORAMC=$P(ORAM0,"^",17) D DT^DILF(,ORAMC,.X) S $P(ORAM0,"^",17)=X
I $P($G(ORAM0),"^",18)'="" S X="",ORAMR=$P(ORAM0,"^",18) D DT^DILF(,ORAMR,.X) S $P(ORAM0,"^",18)=X
I OLDRTN'="" K ^ORAM(103,"L",OLDRTN,DFN)
S ^ORAM(103,DFN,0)=ORAM0 S:$P($G(ORAM0),"^",4)'="" ^ORAM(103,"L",$P(ORAM0,"^",4),DFN)=""
I $P(^ORAM(103,DFN,0),"^",13)="" S $P(^ORAM(103,DFN,0),"^",13)="SAVE"
Q
;
OUTINR(RESULT,ORAMINR) ; INR VALUES FROM OUTSIDE LAB
N ORAMLEN,ORAMPI,ORAMRI,ORAMZANY,ORAMHDT,ORAMNDT
S ORAMLEN=$L($G(ORAMINR),"^"),ORAMRI=0
F ORAMPI=1:2:ORAMLEN D
. N %H,ORAMDT,X
. S ORAMDT=$P(ORAMINR,"^",ORAMPI+1) I $L(ORAMDT) D DT^DILF("E",ORAMDT,.ORAMZANY) S X=ORAMZANY D H^%DTC S ORAMHDT=%H,ORAMNDT=$$FMTE^XLFDT(X,"2P")
. I $L(ORAMDT) S RESULT(ORAMRI)=$P(ORAMINR,"^",ORAMPI)_"^"_$G(ORAMHDT)_"^"_$G(ORAMNDT)
. E S RESULT(ORAMRI)="^^"
. S ORAMRI=ORAMRI+1
Q
;
PCGOAL(RESULT,DFN,CMPLX) ; % of time Pt in current goal
N ORAMSNO,ORAMPC,R,ORAMGOOD,ORAMDATE
S R=0,ORAMGOOD=0,ORAMDATE=0
S ORAMSNO=0 F S ORAMSNO=$O(^ORAM(103,DFN,3,ORAMSNO)) Q:'ORAMSNO D
. N ORAMD0,ORAMINR,ORAMGOAL,ORAMGLOW,ORAMHIGH,LCNT,ORAMND
. S ORAMD0=$G(^ORAM(103,DFN,3,ORAMSNO,0)),LCNT=$P($G(^ORAM(103,DFN,3,ORAMSNO,1,0)),"^",3)-1
. I $G(CMPLX)=1,$G(^ORAM(103,DFN,3,ORAMSNO,1,LCNT,0))["COMPLEX PATIENT" Q
. S ORAMND=$P(ORAMD0,"^"),ORAMINR=$P(ORAMD0,"^",3),ORAMGOAL=$P(ORAMD0,"^",12),ORAMGLOW=$P(ORAMGOAL,"-"),ORAMHIGH=$P(ORAMGOAL,"-",2) S:ORAMHIGH[" " ORAMHIGH=$P(ORAMHIGH," ",2)
. S ORAMGLOW=ORAMGLOW-(.1*ORAMGLOW),ORAMHIGH=ORAMHIGH+(.1*ORAMHIGH)
. I (ORAMND'=ORAMDATE)&(ORAMINR) S R=R+1,ORAMDATE=ORAMND I ((ORAMINR'<ORAMGLOW)&(ORAMINR'>ORAMHIGH)) S ORAMGOOD=ORAMGOOD+1
I R>0 S ORAMPC=(ORAMGOOD/R)*100,ORAMPC=$E(ORAMPC,1,4)
S RESULT=$G(ORAMPC)_"^"_$G(R)
PCGOALQ Q
;
COMPTEST(RESULT,COMMARR) ; File Flow Sheet Data
; RPC: ORAM1 COMPTEST
N ORAMDFN,ORAMZERO,ORAMCOMM,ORAMDT,ORAMX,ORAMCL,ORAMTEMP,ORAMSAVE,ORAMRD,ORAMCOMPL,ORAMCCNT,DA,DIK,R,X
N ORAMICNT,ORAMIOFF
S ORAMDFN=COMMARR(0),ORAMZERO=COMMARR(1),ORAMSAVE=COMMARR(2),ORAMRD=COMMARR(3),ORAMCOMPL=COMMARR(4),ORAMCCNT=COMMARR(5)
S ORAMIOFF=+ORAMCCNT+6,ORAMICNT=COMMARR(ORAMIOFF)
S ORAMTEMP=$P(ORAMZERO,"^",1) D DT^DILF(,ORAMTEMP,.X) S $P(ORAMZERO,"^",1)=$S($G(X)]"":$G(X),1:DT)
S ORAMDT=$$NOW^XLFDT
S:$P(ORAMZERO,"^",9)="" $P(ORAMZERO,"^",9)=ORAMDT
S ORAMX=$O(^ORAM(103,ORAMDFN,3," "),-1)
I 'ORAMX S ORAMX=0
I $P(^ORAM(103,ORAMDFN,0),"^",13)="TEMPSAVE" K DIK,DA S DIK="^ORAM(103,"_ORAMDFN_",3,",DA(1)=ORAMDFN,DA=ORAMX D ^DIK
I $P(^ORAM(103,ORAMDFN,0),"^",13)="SAVE" S ORAMX=ORAMX+1
; Execute KILL Logic for cross-refs on update
I $D(^ORAM(103,ORAMDFN)) D
. S DIK="^ORAM(103,"
. S DA=ORAMDFN
. D IX2^DIK
S ^ORAM(103,ORAMDFN,3,0)="^103.011DA^"_ORAMX_"^"_ORAMX
S ^ORAM(103,ORAMDFN,3,ORAMX,0)=ORAMZERO
I $P(ORAMRD,U,4)]"" S $P(^ORAM(103,ORAMDFN,6),U,1,4)=ORAMRD
E S $P(^ORAM(103,ORAMDFN,6),U,1,3)=$P(ORAMRD,U,1,3)
; If there are comments, file them
I +ORAMCCNT>0 F R=1:1:(ORAMCCNT) D
. S ^ORAM(103,ORAMDFN,3,ORAMX,1,R,0)=COMMARR(R+5)
. S ^ORAM(103,ORAMDFN,3,ORAMX,1,0)="^^"_ORAMCCNT_"^"_ORAMCCNT_"^"_$P(ORAMZERO,"^",1)_"^"
; If there are complications, file them
I $L(ORAMCOMPL)>0 D
. N P1,P2,X
. S P1=$P(ORAMCOMPL,"|"),P2=$P(ORAMCOMPL,"|",2)
. I P1>99 S P1=2 ;CLOT in the 100 range...
. E I P1#10>0 S P1=1 ;MAJOR BLEED
. E I P1=10 S P1=3 ;MINOR BLEED
. S:+$G(P1) $P(^ORAM(103,ORAMDFN,3,ORAMX,0),"^",2)=P1
. F X=1:1:$L(P2,"^") D
.. S ^ORAM(103,ORAMDFN,3,ORAMX,2,X,0)=$P(P2,"^",X)
. S ^ORAM(103,ORAMDFN,3,ORAMX,2,0)="^^"_$L(P2,"^")-1_"^"_$L(P2,"^")-1_"^"_$P(ORAMZERO,"^",1)_"^"
; If there are Patient Instructions, file them
I +ORAMICNT>0 F R=1:1:(ORAMICNT) D
. N ORLINE S ORLINE=COMMARR(R+ORAMIOFF)
. S ^ORAM(103,ORAMDFN,3,ORAMX,3,R,0)=$S(ORLINE="":" ",1:ORLINE)
. S ^ORAM(103,ORAMDFN,3,ORAMX,3,0)="^^"_ORAMICNT_"^"_ORAMICNT_"^"_$P(ORAMZERO,"^",1)_"^"
S ^ORAM(103,ORAMDFN,3,"B",$P(ORAMZERO,"^",1),ORAMX)=""
S $P(^ORAM(103,ORAMDFN,0),"^",13)=ORAMSAVE
; Update all cross-refs for Flow Sheet entry
S DIK="^ORAM(103,"
S DA=ORAMDFN
D IX^DIK
S RESULT=1
Q
;
FLOWTT(RESULT,DFN) ; GETS ANTICOAG FLOWSHEET DATA
N FSARR,COMARR,ORAMI,ORI,ORX
S (ORI,ORAMI,ORX)=0
F S ORI=$O(^ORAM(103,DFN,3,"B",ORI)) Q:+ORI'>0 D
. N ORJ S ORJ=0
. F S ORJ=$O(^ORAM(103,DFN,3,"B",ORI,ORJ)) Q:+ORJ'>0 D
.. N ORAMACFS,ORAMCOM,ORAMCOMP,ORAMCC,ORAMPROV,ORAMLCNT,ORAMTOT,ORAMT,OUTSIDEHCT
.. S ORAMACFS=^ORAM(103,DFN,3,ORJ,0),ORAMCC=$P(ORAMACFS,U,2)
.. S OUTSIDEHCT=$P(^ORAM(103,DFN,6),U,4)
.. S ORAMCOM=$P(ORAMACFS,U),$P(ORAMACFS,U)=$$FMTE^XLFDT(ORAMCOM,"2P"),$P(ORAMACFS,U,2)=ORJ
.. S ORAMPROV=$P(ORAMACFS,U,10) I +$G(ORAMPROV) S $P(ORAMACFS,U,10)=$P(^VA(200,+ORAMPROV,0),U)
.. S ORAMLCNT=+$O(^ORAM(103,DFN,3,ORJ,1,""),-1)
.. S ORAMCOMP=$O(^ORAM(103,DFN,3,ORJ,2,""),-1)
.. S ORAMT=ORAMLCNT
.. S:+$G(ORAMCC) ORAMT=$G(ORAMLCNT)_","_$G(ORAMCOMP)
.. S ORAMTOT=$G(ORAMLCNT)+$G(ORAMCOMP)
.. I +$G(ORAMTOT) D
... S RESULT(ORAMI)=$G(ORAMT)_"|"_$G(ORAMACFS)_U_OUTSIDEHCT
... I +$G(ORAMLCNT) F ORX=(ORAMI+1):1:(ORAMLCNT+ORAMI) S RESULT(ORX)=$G(^ORAM(103,DFN,3,ORJ,1,(ORX-ORAMI),0))
... I +$G(ORAMCC),+$G(ORAMCOMP) D
.... S ORAMI=ORX+2,RESULT(ORAMI)="Complications noted:"
.... F ORX=(ORAMI+2):1:(ORAMCOMP+ORAMI) D
..... N ORAMCMPL
..... S ORAMCMPL=$G(^ORAM(103,DFN,3,ORJ,2,(ORX-ORAMI),0))
..... S RESULT(ORX)=$S((ORAMCMPL["MB:")!(ORAMCMPL["C:"):$P(ORAMCMPL,":",2),1:ORAMCMPL)
.. E S RESULT(ORAMI+1)="0|"_$G(ORAMACFS)
.. S ORAMI=ORX+1
Q
;
LOGIT(RESULT,FSARRAY,ORAMCOMP) ; RPC= ORAM1 LOG
N ORAMDATE,ORAMINR,ORAMPTN,ORAMTWD,ORAMLOG,ORAMLOGN,TODAY,TTIME,COUNT,ORAMODFN,ORAMOD,ORAMND,ORAMNEWD,AROW
N %,DA,DIK,ORAMDFN,ORAMRSF,R,X
S RESULT=0
D NOW^%DTC S TODAY=X,TTIME=%
;FIRST GET THE OLD FLOW SHEET DATA AND SAVE TO THE LOG FILE
S ORAMDFN=$G(FSARRAY(0)),AROW=$G(FSARRAY(1))
S ORAMDATE=$P($G(^ORAM(103,ORAMDFN,3,AROW,0)),"^"),ORAMINR=$P($G(^ORAM(103,ORAMDFN,3,AROW,0)),"^",3),ORAMPTN=$P($G(^ORAM(103,ORAMDFN,3,AROW,0)),"^",8),ORAMTWD=$P($G(^ORAM(103,ORAMDFN,3,AROW,0)),"^",6)
S ORAMODFN=$P($G(^ORAM(103,ORAMDFN,3,AROW,0)),"^",10),ORAMOD=$P($G(^ORAM(103,ORAMDFN,3,AROW,0)),"^",9)
S ORAMLOG="Original FS "_AROW_": DATE="_$G(ORAMDATE)_", INR="_$G(ORAMINR)_", PT NOTIFIED="_$G(ORAMPTN)_", TWD="_$G(ORAMTWD)_"; "_ORAMODFN_" ("_ORAMOD_"): EDITED: "_FSARRAY(6)_"("_TODAY_")"
S ORAMLOGN=$P($G(^ORAM(103,ORAMDFN,3,AROW,"LOG",0)),"^",3)+1
S ^ORAM(103,ORAMDFN,3,AROW,"LOG",ORAMLOGN,0)=ORAMLOG
K ^ORAM(103,ORAMDFN,3,"B",$G(ORAMDATE),AROW)
F ORAMRSF=1:1:$P($G(^ORAM(103,ORAMDFN,3,AROW,1,0)),"^",3) S COUNT=ORAMLOGN+ORAMRSF,^ORAM(103,ORAMDFN,3,AROW,"LOG",COUNT,0)=^ORAM(103,ORAMDFN,3,AROW,1,ORAMRSF,0)
S ^ORAM(103,ORAMDFN,3,AROW,"LOG",0)="^^"_$G(COUNT)_"^"_$G(COUNT)_"^"_TODAY
;NOW SET NEW INFO FOR THE FLOW SHEET ENTRY
;Array order is: DFN;ARow;date;inr;ptnotified;twd;DUZ;#comment lines;comments
S ORAMNEWD=$G(FSARRAY(2)) D DT^DILF(,ORAMNEWD,.X) S ORAMNEWD=X
S $P(^ORAM(103,ORAMDFN,3,AROW,0),"^")=$G(ORAMNEWD),$P(^ORAM(103,ORAMDFN,3,AROW,0),"^",3)=$G(FSARRAY(3)),$P(^ORAM(103,ORAMDFN,3,AROW,0),"^",8)=$G(FSARRAY(4)),$P(^ORAM(103,ORAMDFN,3,AROW,0),"^",6)=$G(FSARRAY(5))
I $G(ORAMCOMP)=0 S $P(^ORAM(103,ORAMDFN,3,AROW,0),"^",2)=0
S $P(^ORAM(103,ORAMDFN,3,AROW,0),"^",10)=$G(FSARRAY(6)),$P(^ORAM(103,ORAMDFN,3,AROW,0),"^",9)=TTIME
I $G(FSARRAY(7))'="" K ^ORAM(103,ORAMDFN,3,AROW,1) F R=1:1:$G(FSARRAY(7)) D
. S ^ORAM(103,ORAMDFN,3,AROW,1,R,0)=$G(FSARRAY(R+7))
S ^ORAM(103,ORAMDFN,3,AROW,1,0)="^^"_$G(FSARRAY(7))_"^"_$G(FSARRAY(7))_"^"_TODAY_"^" ;$E(ORAMDT,1,7)_"^"
S ^ORAM(103,ORAMDFN,3,"B",$G(ORAMNEWD),AROW)=""
S DIK="^ORAM(103,"
S DA(1)=ORAMDFN,DA=AROW
D IX^DIK
S RESULT=1
Q
;
LOCK(RESULT,DATA) ; Locks form RPC=ORAM1 LOCK
N X
S RESULT=0
Q:$P($G(DATA),"^")=""
Q:$D(^ORAM(103,$P(DATA,"^")))=0
D NOW^%DTC N ORAMTDAY S ORAMTDAY=X
I $P(^ORAM(103,$P(DATA,"^"),0),"^",18,19)="" S $P(^ORAM(103,$P(DATA,"^"),0),"^",18)="^"
S $P(^ORAM(103,$P(DATA,"^"),0),"^",19)=1_"|"_$P(^VA(200,$P(DATA,"^",2),0),"^")_"|"_ORAMTDAY,RESULT=1
Q
;
UNLOCK(RESULT,DFN) ; Unlocks form RPC=ORAM1 UNLOCK
S RESULT=0
Q:DFN<1
Q:$D(^ORAM(103,DFN))=0
S $P(^ORAM(103,DFN,0),"^",19)=0,RESULT=1
Q
;
GETPT(RESULT) ; Get Pt list RPC=ORAM1 PT LIST
N ORAMPT
S ORAMPT=0 F S ORAMPT=$O(^ORAM(103,"B",ORAMPT)) Q:ORAMPT="" D
. S RESULT($G(ORAMPT))=$G(ORAMPT)_"^"_$P(^DPT(ORAMPT,0),"^")_"^"_$E($P(^DPT(ORAMPT,0),"^",9),6,9)
Q
;
SETHCT(RESULT,ORAMORD) ; SET HCT LAB ITEM NUMBER
Q:'+$G(ORAMORD)
N ORAMX,ORAML60,ORAMCH S ORAMX=0 F S ORAMX=$O(^ORD(101.43,$G(ORAMORD),10,ORAMX)) Q:'+$G(ORAMX)!+$G(ORAMCH) D
. I $P(^ORD(101.43,$G(ORAMORD),10,ORAMX,0),"^")["HCT" S ORAML60=+$P(^(0),"^",2)
. I +$G(ORAML60) S ORAMCH=$P($P(^LAB(60,ORAML60,0),"^",5),";",2) S RESULT=ORAMCH
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORAM1 15963 printed Oct 16, 2024@18:27:34 Page 2
ORAM1 ;POR/RSF - ANTICOAGULATION MANAGEMENT RPCS (2 of 4) ; 3/23/18 3:14pm
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**307,339,351,361,391,474,463**;Dec 17, 1997;Build 5
+2 ;;Per VHA Directive 2004-038, this routine should not be modified
+3 QUIT
+4 ;
+5 ; External References:
+6 ; $$EXTERNAL^DILFD ICR #2055
+7 ; $$FMTE/$$NOW^XLFDT ICR #10103
+8 ; $$GET^XPAR ICR #2263
+9 ;
TERASE(RESULT,ORAMDFN,ORAMCOMP) ; Manage Team Lists
+1 NEW ORAMKEY,ORAMTMP,ORAMCEY,ORAMCLIN,ORAMCLNM,ORAMCOM,ORAMALL,ORAMCPLX,ORAMENT,QQ,DA,DIK,D0
+2 if '+$GET(ORAMDFN)
QUIT
+3 SET ORAMCLIN=+$PIECE($GET(^ORAM(103,ORAMDFN,6)),U,2)
SET ORAMENT=$SELECT(+ORAMCLIN>0:ORAMCLIN_";SC(",1:"ALL")
+4 IF +ORAMCLIN
SET ORAMCLNM=$$EXTERNAL^DILFD(103,101,"",ORAMCLIN)
+5 SET ORAMALL=$$GET^XPAR(ORAMENT,"ORAM TEAM LIST (ALL)",1,"I")
SET ORAMCPLX=$$GET^XPAR(ORAMENT,"ORAM TEAM LIST (COMPLEX)",1,"I")
+6 IF +$GET(ORAMALL)
Begin DoDot:1
+7 SET DA(1)=ORAMALL
SET DIK="^OR(100.21"_","_DA(1)_",10,"
+8 SET ORAMTMP=ORAMDFN_";DPT("
+9 SET ORAMKEY=$ORDER(^OR(100.21,ORAMALL,10,"B",ORAMTMP,0))
if +ORAMKEY'>0
QUIT
SET DA=ORAMKEY
+10 DO ^DIK
+11 KILL DA,DIK
+12 KILL D0
+13 SET RESULT=1
End DoDot:1
IF 1
+14 IF '$TEST
SET RESULT="0^ORAM TEAM LIST (ALL) not defined for Clinic "_ORAMCLNM_"."
+15 IF +$GET(ORAMCPLX)
Begin DoDot:1
+16 SET DA(1)=ORAMCPLX
SET DIK="^OR(100.21"_","_DA(1)_",10,"
+17 SET ORAMCEY=$ORDER(^OR(100.21,ORAMCPLX,10,"B",ORAMTMP,0))
if +ORAMCEY'>0
QUIT
SET DA=ORAMCEY
+18 DO ^DIK
+19 KILL DA,DIK
+20 if '$DATA(RESULT)
SET RESULT=1
End DoDot:1
IF 1
+21 IF '$TEST
SET RESULT="0^ORAM TEAM LIST (COMPLEX) not defined for Clinic "_ORAMCLNM_"."
+22 QUIT
+23 ;
+24 ;ICDCODE(RESULT,ICODE); Map ICD Code //REMOVED BECAUSE OF DIRECT READ OF ^ICD9( FILE
+25 ;N ORAMICD
+26 ;S ORAMICD=ICODE_" "
+27 ;S RESULT=$O(^ICD9("AB",ORAMICD,0))
+28 ;Q
+29 ;
PTCHECK(RESULT,ORAMDFN) ; CHECKS TO SEE IF PT IS IN FILE
+1 NEW ORPTLOC
+2 if '+$GET(ORAMDFN)
QUIT
+3 SET RESULT=0
+4 IF $SELECT('$DATA(^ORAM(103,ORAMDFN)):1,+$ORDER(^ORAM(103,ORAMDFN,3,0))'>0:1,1:0)
SET RESULT=1
QUIT
+5 SET ORPTLOC=$PIECE($GET(^ORAM(103,ORAMDFN,6)),U,2)
+6 IF ORPTLOC']""
SET RESULT=2
QUIT
+7 IF +ORPTLOC
IF '$LENGTH($$GET^XPAR(ORPTLOC_";SC(^DIV.`"_DUZ(2),"ORAM CLINIC NAME",1,"I"))
SET RESULT=99
+8 QUIT
+9 ;
PTENTER(RESULT,DFN) ; ENTERS PATIENT INTO FILE WITH ALL DATES = TODAY
+1 NEW DO,DD,DIC,DINUM,X
+2 SET DIC="^ORAM(103,"
+3 SET DIC(0)="Z"
+4 SET (DINUM,X)=DFN
+5 DO FILE^DICN
+6 KILL DO,DD
+7 SET RESULT=1
+8 QUIT
+9 ;
ACDATA(RESULT,DFN,ORAMEDT) ; HEADING DATA
+1 NEW ORAMSTOT,ORAMRTOT,ORAMRAT,ORAMMSGT,ORAMRAT,ORAMBRT,ORAMX,ORI,ORLINE
+2 NEW ORAMD0,ORAMD4,ORAMD5,ORAMD6,ORAMD9,ORAMD15,ORAMD17,ORAMD18
+3 NEW ORAMT4,ORAMT5,ORAMT6,ORAMT9,ORAMT15,ORAMT17,ORAMT18,ORAMDXT,ORAMDXC,ORDXI,ORAMPOP
+4 SET ORAMEDT=$GET(ORAMEDT,DT)
+5 SET ORAMX=0
+6 ;IF NOT IN FILE ALREADY...
IF '$DATA(^ORAM(103,DFN))
Begin DoDot:1
+7 NEW DD,DIC,DINUM,DO,X
+8 SET DIC="^ORAM(103,"
+9 SET DIC(0)="Z"
+10 SET (DINUM,X)=DFN
+11 DO FILE^DICN
+12 KILL DO,DD
+13 SET ORAMX=1
End DoDot:1
+14 IF ORAMX=1
SET RESULT(0)=0
GOTO ACDATAQ
+15 SET ORAMD0=^ORAM(103,DFN,0)
+16 SET ORI=0
FOR
SET ORI=$ORDER(^ORAM(103,DFN,1,ORI))
if +ORI'>0
QUIT
SET ORLINE=$GET(^ORAM(103,DFN,1,ORI,0))
if ORLINE=""
SET ORLINE=" "
SET ORAMSTOT=$GET(ORAMSTOT)_U_ORLINE
+17 SET ORI=0
FOR
SET ORI=$ORDER(^ORAM(103,DFN,2,ORI))
if +ORI'>0
QUIT
SET ORLINE=$GET(^ORAM(103,DFN,2,ORI,0))
if ORLINE=""
SET ORLINE=" "
SET ORAMRTOT=$GET(ORAMRTOT)_U_ORLINE
+18 SET ORI=0
FOR
SET ORI=$ORDER(^ORAM(103,DFN,4,ORI))
if +ORI'>0
QUIT
SET ORLINE=$GET(^ORAM(103,DFN,4,ORI,0))
if ORLINE=""
SET ORLINE=" "
SET ORAMMSGT=$GET(ORAMMSGT)_U_ORLINE
+19 SET ORI=0
FOR
SET ORI=$ORDER(^ORAM(103,DFN,5,ORI))
if +ORI'>0
QUIT
SET ORLINE=$GET(^ORAM(103,DFN,5,ORI,0))
if ORLINE=""
SET ORLINE=" "
SET ORAMRAT=$GET(ORAMRAT)_U_ORLINE
+20 SET ORI=0
FOR
SET ORI=$ORDER(^ORAM(103,DFN,7,ORI))
if +ORI'>0
QUIT
SET ORLINE=$GET(^ORAM(103,DFN,7,ORI,0))
if ORLINE=""
SET ORLINE=" "
SET ORAMBRT=$GET(ORAMBRT)_U_ORLINE
+21 SET RESULT(0)=$GET(ORAMSTOT)
+22 SET RESULT(1)=$GET(ORAMRTOT)
+23 SET RESULT(2)=$GET(ORAMMSGT)
+24 SET RESULT(4)=$GET(ORAMRAT)
+25 SET RESULT(5)=$SELECT($GET(ORAMBRT)]"":$PIECE($GET(^ORAM(103,DFN,6)),"^",5)_"^"_$PIECE($GET(ORAMBRT),"^",2,99),1:"")
+26 SET ORAMD4=$PIECE(ORAMD0,"^",4)
SET ORAMD5=$PIECE(ORAMD0,"^",5)
SET ORAMD6=$PIECE(ORAMD0,"^",6)
SET ORAMD9=$PIECE(ORAMD0,"^",9)
SET ORAMD15=$PIECE(ORAMD0,"^",15)
SET ORAMD17=$PIECE(ORAMD0,"^",17)
SET ORAMD18=$PIECE(ORAMD0,"^",18)
+27 SET ORAMT4=$$FMTE^XLFDT($EXTRACT($GET(ORAMD4),1,12),"2P")
SET ORAMT5=$$FMTE^XLFDT($EXTRACT($GET(ORAMD5),1,12),"2P")
SET ORAMT6=$$FMTE^XLFDT($EXTRACT($GET(ORAMD6),1,12),"2P")
SET ORAMT9=$$FMTE^XLFDT($EXTRACT($GET(ORAMD9),1,12),"2P")
+28 SET ORAMT15=$$FMTE^XLFDT($EXTRACT($GET(ORAMD15),1,12),"2P")
SET ORAMT17=$$FMTE^XLFDT($EXTRACT($GET(ORAMD17),1,12),"2P")
SET ORAMT18=$$FMTE^XLFDT($EXTRACT($GET(ORAMD18),1,12),"2P")
+29 if $LENGTH($PIECE(ORAMT4,"/",1))=1
SET $PIECE(ORAMT4,"/",1)="0"_$PIECE(ORAMT4,"/",1)
+30 if $LENGTH($PIECE(ORAMT4,"/",2))=1
SET $PIECE(ORAMT4,"/",2)="0"_$PIECE(ORAMT4,"/",2)
+31 if $LENGTH($PIECE(ORAMT15,"/",1))=1
SET $PIECE(ORAMT15,"/",1)="0"_$PIECE(ORAMT15,"/",1)
+32 if $LENGTH($PIECE(ORAMT15,"/",2))=1
SET $PIECE(ORAMT15,"/",2)="0"_$PIECE(ORAMT15,"/",2)
+33 if $LENGTH($PIECE(ORAMT17,"/",1))=1
SET $PIECE(ORAMT17,"/",1)="0"_$PIECE(ORAMT17,"/",1)
+34 if $LENGTH($PIECE(ORAMT17,"/",2))=1
SET $PIECE(ORAMT17,"/",2)="0"_$PIECE(ORAMT17,"/",2)
+35 if $LENGTH($PIECE(ORAMT18,"/",1))=1
SET $PIECE(ORAMT18,"/",1)="0"_$PIECE(ORAMT18,"/",1)
+36 if $LENGTH($PIECE(ORAMT18,"/",2))=1
SET $PIECE(ORAMT18,"/",2)="0"_$PIECE(ORAMT18,"/",2)
+37 ; OR*3*391 Check validity of legacy Dx code
+38 SET ORAMDXT=$PIECE($PIECE(ORAMD0,U,3),"=")
SET ORAMDXC=$PIECE($PIECE(ORAMD0,U,3),"=",2)
SET ORAMPOP=0
+39 FOR ORDXI=1:1:$LENGTH(ORAMDXC,"/")
Begin DoDot:1
+40 NEW ORDXC,ORDX
SET ORDXC=$PIECE(ORAMDXC,"/",ORDXI)
+41 IF (ORDXC]"")
IF (ORDXC'[".")
SET ORDXC=ORDXC_"."
+42 SET ORDX=+$$ICDDATA^ICDXCODE("DIAGNOSIS",ORDXC,ORAMEDT,"E")
+43 IF +ORDX'>0
SET ORAMDXC=""
End DoDot:1
if +ORAMPOP
QUIT
+44 SET $PIECE(ORAMD0,U,3)=ORAMDXT_"="_ORAMDXC
+45 SET $PIECE(ORAMD0,"^",4)=$GET(ORAMT4)
SET $PIECE(ORAMD0,"^",5)=$GET(ORAMT5)
SET $PIECE(ORAMD0,"^",6)=$GET(ORAMT6)
SET $PIECE(ORAMD0,"^",9)=$GET(ORAMT9)
SET $PIECE(ORAMD0,"^",15)=$GET(ORAMT15)
SET $PIECE(ORAMD0,"^",17)=$GET(ORAMT17)
SET $PIECE(ORAMD0,"^",18)=$GET(ORAMT18)
+46 SET RESULT(3)=ORAMD0
if $DATA(^ORAM(103,DFN,6))
SET RESULT(3)=RESULT(3)_"^"_$PIECE(^ORAM(103,DFN,6),"^")
ACDATAQ QUIT
+1 ;
ADDTOP(RESULT,TOPARR) ; File ANTICOAG data
+1 NEW ORAM0,SI,RISK,PEEP,ORAMSIL,ORAMRL,ORAMPEPL,ORAMDAY,ORAMST,ORAMBACK,ORAMSTP,ORAMOR,ORAMFB,ORAMREM,ORAMRML,ORAMR,ORAMC
+2 NEW ORAMBRG,ORAMBRGC,ORAMBRGL,ORAMLOC,OLDRTN,DFN,R,X,FDA
+3 DO NOW^%DTC
SET ORAMDAY=X
+4 SET DFN=TOPARR(0)
SET ORAM0=TOPARR(1)
SET SI=TOPARR(2)
SET RISK=TOPARR(3)
SET PEEP=TOPARR(4)
SET ORAMREM=TOPARR(5)
+5 SET ORAMBRG=$GET(TOPARR(6))
SET ORAMBRGC=$GET(TOPARR(7))
SET ORAMLOC=$GET(TOPARR(8))
+6 SET OLDRTN=$PIECE($GET(^ORAM(103,DFN,0)),"^",4)
+7 IF SI'=""
KILL ^ORAM(103,DFN,1)
SET ORAMSIL=$LENGTH(SI,"^")
SET ^ORAM(103,DFN,1,0)="^^"_ORAMSIL_"^"_ORAMSIL_"^"_ORAMDAY_"^"
FOR R=1:1:ORAMSIL
Begin DoDot:1
+8 SET ^ORAM(103,DFN,1,R,0)=$PIECE(SI,"^",R)
End DoDot:1
+9 IF RISK'=""
KILL ^ORAM(103,DFN,2)
SET ORAMRL=$LENGTH(RISK,"^")
SET ^ORAM(103,DFN,2,0)="^^"_ORAMRL_"^"_ORAMRL_"^"_ORAMDAY_"^"
FOR R=1:1:ORAMRL
Begin DoDot:1
+10 SET ^ORAM(103,DFN,2,R,0)=$PIECE(RISK,"^",R)
End DoDot:1
+11 IF PEEP'=""
KILL ^ORAM(103,DFN,4)
SET ORAMPEPL=$LENGTH(PEEP,"^")
SET ^ORAM(103,DFN,4,0)="^^"_ORAMPEPL_"^"_ORAMPEPL_"^"_ORAMDAY_"^"
FOR R=1:1:ORAMPEPL
Begin DoDot:1
+12 SET ^ORAM(103,DFN,4,R,0)=$PIECE(PEEP,"^",R)
End DoDot:1
+13 KILL ^ORAM(103,DFN,5)
+14 IF ORAMREM'=""
Begin DoDot:1
+15 SET ORAMRML=$LENGTH(ORAMREM,"^")
SET ^ORAM(103,DFN,5,0)="^^"_ORAMRML_"^"_ORAMRML_"^"_ORAMDAY_"^"
+16 FOR R=1:1:ORAMRML
SET ^ORAM(103,DFN,5,R,0)=$PIECE(ORAMREM,"^",R)
End DoDot:1
+17 ;*351 Use Fileman so x-ref updates.
+18 if ORAMLOC>0
SET FDA(1,103,DFN_",",101)=ORAMLOC
+19 SET FDA(1,103,DFN_",",111)=+ORAMBRG
+20 DO UPDATE^DIE(,"FDA(1)")
+21 IF +ORAMBRG
IF (ORAMBRGC]"")
Begin DoDot:1
+22 KILL ^ORAM(103,DFN,7)
+23 SET ORAMBRGL=$LENGTH(ORAMBRGC,"^")
SET ^ORAM(103,DFN,7,0)="^^"_ORAMBRGL_"^"_ORAMBRGL_"^"_ORAMDAY_"^"
+24 FOR R=1:1:ORAMBRGL
SET ^ORAM(103,DFN,7,R,0)=$PIECE(ORAMBRGC,"^",R)
End DoDot:1
+25 IF $PIECE($GET(ORAM0),"^",4)'=""
SET X=""
SET ORAMBACK=$PIECE(ORAM0,"^",4)
DO DT^DILF("TS",ORAMBACK,.X)
SET $PIECE(ORAM0,"^",4)=X
+26 IF $PIECE($GET(ORAM0),"^",15)'=""
SET X=""
SET ORAMFB=$PIECE(ORAM0,"^",15)
DO DT^DILF(,ORAMFB,.X)
SET $PIECE(ORAM0,"^",15)=X
+27 IF $PIECE($GET(ORAM0),"^",17)'=""
SET X=""
SET ORAMC=$PIECE(ORAM0,"^",17)
DO DT^DILF(,ORAMC,.X)
SET $PIECE(ORAM0,"^",17)=X
+28 IF $PIECE($GET(ORAM0),"^",18)'=""
SET X=""
SET ORAMR=$PIECE(ORAM0,"^",18)
DO DT^DILF(,ORAMR,.X)
SET $PIECE(ORAM0,"^",18)=X
+29 IF OLDRTN'=""
KILL ^ORAM(103,"L",OLDRTN,DFN)
+30 SET ^ORAM(103,DFN,0)=ORAM0
if $PIECE($GET(ORAM0),"^",4)'=""
SET ^ORAM(103,"L",$PIECE(ORAM0,"^",4),DFN)=""
+31 IF $PIECE(^ORAM(103,DFN,0),"^",13)=""
SET $PIECE(^ORAM(103,DFN,0),"^",13)="SAVE"
+32 QUIT
+33 ;
OUTINR(RESULT,ORAMINR) ; INR VALUES FROM OUTSIDE LAB
+1 NEW ORAMLEN,ORAMPI,ORAMRI,ORAMZANY,ORAMHDT,ORAMNDT
+2 SET ORAMLEN=$LENGTH($GET(ORAMINR),"^")
SET ORAMRI=0
+3 FOR ORAMPI=1:2:ORAMLEN
Begin DoDot:1
+4 NEW %H,ORAMDT,X
+5 SET ORAMDT=$PIECE(ORAMINR,"^",ORAMPI+1)
IF $LENGTH(ORAMDT)
DO DT^DILF("E",ORAMDT,.ORAMZANY)
SET X=ORAMZANY
DO H^%DTC
SET ORAMHDT=%H
SET ORAMNDT=$$FMTE^XLFDT(X,"2P")
+6 IF $LENGTH(ORAMDT)
SET RESULT(ORAMRI)=$PIECE(ORAMINR,"^",ORAMPI)_"^"_$GET(ORAMHDT)_"^"_$GET(ORAMNDT)
+7 IF '$TEST
SET RESULT(ORAMRI)="^^"
+8 SET ORAMRI=ORAMRI+1
End DoDot:1
+9 QUIT
+10 ;
PCGOAL(RESULT,DFN,CMPLX) ; % of time Pt in current goal
+1 NEW ORAMSNO,ORAMPC,R,ORAMGOOD,ORAMDATE
+2 SET R=0
SET ORAMGOOD=0
SET ORAMDATE=0
+3 SET ORAMSNO=0
FOR
SET ORAMSNO=$ORDER(^ORAM(103,DFN,3,ORAMSNO))
if 'ORAMSNO
QUIT
Begin DoDot:1
+4 NEW ORAMD0,ORAMINR,ORAMGOAL,ORAMGLOW,ORAMHIGH,LCNT,ORAMND
+5 SET ORAMD0=$GET(^ORAM(103,DFN,3,ORAMSNO,0))
SET LCNT=$PIECE($GET(^ORAM(103,DFN,3,ORAMSNO,1,0)),"^",3)-1
+6 IF $GET(CMPLX)=1
IF $GET(^ORAM(103,DFN,3,ORAMSNO,1,LCNT,0))["COMPLEX PATIENT"
QUIT
+7 SET ORAMND=$PIECE(ORAMD0,"^")
SET ORAMINR=$PIECE(ORAMD0,"^",3)
SET ORAMGOAL=$PIECE(ORAMD0,"^",12)
SET ORAMGLOW=$PIECE(ORAMGOAL,"-")
SET ORAMHIGH=$PIECE(ORAMGOAL,"-",2)
if ORAMHIGH[" "
SET ORAMHIGH=$PIECE(ORAMHIGH," ",2)
+8 SET ORAMGLOW=ORAMGLOW-(.1*ORAMGLOW)
SET ORAMHIGH=ORAMHIGH+(.1*ORAMHIGH)
+9 IF (ORAMND'=ORAMDATE)&(ORAMINR)
SET R=R+1
SET ORAMDATE=ORAMND
IF ((ORAMINR'<ORAMGLOW)&(ORAMINR'>ORAMHIGH))
SET ORAMGOOD=ORAMGOOD+1
End DoDot:1
+10 IF R>0
SET ORAMPC=(ORAMGOOD/R)*100
SET ORAMPC=$EXTRACT(ORAMPC,1,4)
+11 SET RESULT=$GET(ORAMPC)_"^"_$GET(R)
PCGOALQ QUIT
+1 ;
COMPTEST(RESULT,COMMARR) ; File Flow Sheet Data
+1 ; RPC: ORAM1 COMPTEST
+2 NEW ORAMDFN,ORAMZERO,ORAMCOMM,ORAMDT,ORAMX,ORAMCL,ORAMTEMP,ORAMSAVE,ORAMRD,ORAMCOMPL,ORAMCCNT,DA,DIK,R,X
+3 NEW ORAMICNT,ORAMIOFF
+4 SET ORAMDFN=COMMARR(0)
SET ORAMZERO=COMMARR(1)
SET ORAMSAVE=COMMARR(2)
SET ORAMRD=COMMARR(3)
SET ORAMCOMPL=COMMARR(4)
SET ORAMCCNT=COMMARR(5)
+5 SET ORAMIOFF=+ORAMCCNT+6
SET ORAMICNT=COMMARR(ORAMIOFF)
+6 SET ORAMTEMP=$PIECE(ORAMZERO,"^",1)
DO DT^DILF(,ORAMTEMP,.X)
SET $PIECE(ORAMZERO,"^",1)=$SELECT($GET(X)]"":$GET(X),1:DT)
+7 SET ORAMDT=$$NOW^XLFDT
+8 if $PIECE(ORAMZERO,"^",9)=""
SET $PIECE(ORAMZERO,"^",9)=ORAMDT
+9 SET ORAMX=$ORDER(^ORAM(103,ORAMDFN,3," "),-1)
+10 IF 'ORAMX
SET ORAMX=0
+11 IF $PIECE(^ORAM(103,ORAMDFN,0),"^",13)="TEMPSAVE"
KILL DIK,DA
SET DIK="^ORAM(103,"_ORAMDFN_",3,"
SET DA(1)=ORAMDFN
SET DA=ORAMX
DO ^DIK
+12 IF $PIECE(^ORAM(103,ORAMDFN,0),"^",13)="SAVE"
SET ORAMX=ORAMX+1
+13 ; Execute KILL Logic for cross-refs on update
+14 IF $DATA(^ORAM(103,ORAMDFN))
Begin DoDot:1
+15 SET DIK="^ORAM(103,"
+16 SET DA=ORAMDFN
+17 DO IX2^DIK
End DoDot:1
+18 SET ^ORAM(103,ORAMDFN,3,0)="^103.011DA^"_ORAMX_"^"_ORAMX
+19 SET ^ORAM(103,ORAMDFN,3,ORAMX,0)=ORAMZERO
+20 IF $PIECE(ORAMRD,U,4)]""
SET $PIECE(^ORAM(103,ORAMDFN,6),U,1,4)=ORAMRD
+21 IF '$TEST
SET $PIECE(^ORAM(103,ORAMDFN,6),U,1,3)=$PIECE(ORAMRD,U,1,3)
+22 ; If there are comments, file them
+23 IF +ORAMCCNT>0
FOR R=1:1:(ORAMCCNT)
Begin DoDot:1
+24 SET ^ORAM(103,ORAMDFN,3,ORAMX,1,R,0)=COMMARR(R+5)
+25 SET ^ORAM(103,ORAMDFN,3,ORAMX,1,0)="^^"_ORAMCCNT_"^"_ORAMCCNT_"^"_$PIECE(ORAMZERO,"^",1)_"^"
End DoDot:1
+26 ; If there are complications, file them
+27 IF $LENGTH(ORAMCOMPL)>0
Begin DoDot:1
+28 NEW P1,P2,X
+29 SET P1=$PIECE(ORAMCOMPL,"|")
SET P2=$PIECE(ORAMCOMPL,"|",2)
+30 ;CLOT in the 100 range...
IF P1>99
SET P1=2
+31 ;MAJOR BLEED
IF '$TEST
IF P1#10>0
SET P1=1
+32 ;MINOR BLEED
IF '$TEST
IF P1=10
SET P1=3
+33 if +$GET(P1)
SET $PIECE(^ORAM(103,ORAMDFN,3,ORAMX,0),"^",2)=P1
+34 FOR X=1:1:$LENGTH(P2,"^")
Begin DoDot:2
+35 SET ^ORAM(103,ORAMDFN,3,ORAMX,2,X,0)=$PIECE(P2,"^",X)
End DoDot:2
+36 SET ^ORAM(103,ORAMDFN,3,ORAMX,2,0)="^^"_$LENGTH(P2,"^")-1_"^"_$LENGTH(P2,"^")-1_"^"_$PIECE(ORAMZERO,"^",1)_"^"
End DoDot:1
+37 ; If there are Patient Instructions, file them
+38 IF +ORAMICNT>0
FOR R=1:1:(ORAMICNT)
Begin DoDot:1
+39 NEW ORLINE
SET ORLINE=COMMARR(R+ORAMIOFF)
+40 SET ^ORAM(103,ORAMDFN,3,ORAMX,3,R,0)=$SELECT(ORLINE="":" ",1:ORLINE)
+41 SET ^ORAM(103,ORAMDFN,3,ORAMX,3,0)="^^"_ORAMICNT_"^"_ORAMICNT_"^"_$PIECE(ORAMZERO,"^",1)_"^"
End DoDot:1
+42 SET ^ORAM(103,ORAMDFN,3,"B",$PIECE(ORAMZERO,"^",1),ORAMX)=""
+43 SET $PIECE(^ORAM(103,ORAMDFN,0),"^",13)=ORAMSAVE
+44 ; Update all cross-refs for Flow Sheet entry
+45 SET DIK="^ORAM(103,"
+46 SET DA=ORAMDFN
+47 DO IX^DIK
+48 SET RESULT=1
+49 QUIT
+50 ;
FLOWTT(RESULT,DFN) ; GETS ANTICOAG FLOWSHEET DATA
+1 NEW FSARR,COMARR,ORAMI,ORI,ORX
+2 SET (ORI,ORAMI,ORX)=0
+3 FOR
SET ORI=$ORDER(^ORAM(103,DFN,3,"B",ORI))
if +ORI'>0
QUIT
Begin DoDot:1
+4 NEW ORJ
SET ORJ=0
+5 FOR
SET ORJ=$ORDER(^ORAM(103,DFN,3,"B",ORI,ORJ))
if +ORJ'>0
QUIT
Begin DoDot:2
+6 NEW ORAMACFS,ORAMCOM,ORAMCOMP,ORAMCC,ORAMPROV,ORAMLCNT,ORAMTOT,ORAMT,OUTSIDEHCT
+7 SET ORAMACFS=^ORAM(103,DFN,3,ORJ,0)
SET ORAMCC=$PIECE(ORAMACFS,U,2)
+8 SET OUTSIDEHCT=$PIECE(^ORAM(103,DFN,6),U,4)
+9 SET ORAMCOM=$PIECE(ORAMACFS,U)
SET $PIECE(ORAMACFS,U)=$$FMTE^XLFDT(ORAMCOM,"2P")
SET $PIECE(ORAMACFS,U,2)=ORJ
+10 SET ORAMPROV=$PIECE(ORAMACFS,U,10)
IF +$GET(ORAMPROV)
SET $PIECE(ORAMACFS,U,10)=$PIECE(^VA(200,+ORAMPROV,0),U)
+11 SET ORAMLCNT=+$ORDER(^ORAM(103,DFN,3,ORJ,1,""),-1)
+12 SET ORAMCOMP=$ORDER(^ORAM(103,DFN,3,ORJ,2,""),-1)
+13 SET ORAMT=ORAMLCNT
+14 if +$GET(ORAMCC)
SET ORAMT=$GET(ORAMLCNT)_","_$GET(ORAMCOMP)
+15 SET ORAMTOT=$GET(ORAMLCNT)+$GET(ORAMCOMP)
+16 IF +$GET(ORAMTOT)
Begin DoDot:3
+17 SET RESULT(ORAMI)=$GET(ORAMT)_"|"_$GET(ORAMACFS)_U_OUTSIDEHCT
+18 IF +$GET(ORAMLCNT)
FOR ORX=(ORAMI+1):1:(ORAMLCNT+ORAMI)
SET RESULT(ORX)=$GET(^ORAM(103,DFN,3,ORJ,1,(ORX-ORAMI),0))
+19 IF +$GET(ORAMCC)
IF +$GET(ORAMCOMP)
Begin DoDot:4
+20 SET ORAMI=ORX+2
SET RESULT(ORAMI)="Complications noted:"
+21 FOR ORX=(ORAMI+2):1:(ORAMCOMP+ORAMI)
Begin DoDot:5
+22 NEW ORAMCMPL
+23 SET ORAMCMPL=$GET(^ORAM(103,DFN,3,ORJ,2,(ORX-ORAMI),0))
+24 SET RESULT(ORX)=$SELECT((ORAMCMPL["MB:")!(ORAMCMPL["C:"):$PIECE(ORAMCMPL,":",2),1:ORAMCMPL)
End DoDot:5
End DoDot:4
End DoDot:3
+25 IF '$TEST
SET RESULT(ORAMI+1)="0|"_$GET(ORAMACFS)
+26 SET ORAMI=ORX+1
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;
LOGIT(RESULT,FSARRAY,ORAMCOMP) ; RPC= ORAM1 LOG
+1 NEW ORAMDATE,ORAMINR,ORAMPTN,ORAMTWD,ORAMLOG,ORAMLOGN,TODAY,TTIME,COUNT,ORAMODFN,ORAMOD,ORAMND,ORAMNEWD,AROW
+2 NEW %,DA,DIK,ORAMDFN,ORAMRSF,R,X
+3 SET RESULT=0
+4 DO NOW^%DTC
SET TODAY=X
SET TTIME=%
+5 ;FIRST GET THE OLD FLOW SHEET DATA AND SAVE TO THE LOG FILE
+6 SET ORAMDFN=$GET(FSARRAY(0))
SET AROW=$GET(FSARRAY(1))
+7 SET ORAMDATE=$PIECE($GET(^ORAM(103,ORAMDFN,3,AROW,0)),"^")
SET ORAMINR=$PIECE($GET(^ORAM(103,ORAMDFN,3,AROW,0)),"^",3)
SET ORAMPTN=$PIECE($GET(^ORAM(103,ORAMDFN,3,AROW,0)),"^",8)
SET ORAMTWD=$PIECE($GET(^ORAM(103,ORAMDFN,3,AROW,0)),"^",6)
+8 SET ORAMODFN=$PIECE($GET(^ORAM(103,ORAMDFN,3,AROW,0)),"^",10)
SET ORAMOD=$PIECE($GET(^ORAM(103,ORAMDFN,3,AROW,0)),"^",9)
+9 SET ORAMLOG="Original FS "_AROW_": DATE="_$GET(ORAMDATE)_", INR="_$GET(ORAMINR)_", PT NOTIFIED="_$GET(ORAMPTN)_", TWD="_$GET(ORAMTWD)_"; "_ORAMODFN_" ("_ORAMOD_"): EDITED: "_FSARRAY(6)_"("_TODAY_")"
+10 SET ORAMLOGN=$PIECE($GET(^ORAM(103,ORAMDFN,3,AROW,"LOG",0)),"^",3)+1
+11 SET ^ORAM(103,ORAMDFN,3,AROW,"LOG",ORAMLOGN,0)=ORAMLOG
+12 KILL ^ORAM(103,ORAMDFN,3,"B",$GET(ORAMDATE),AROW)
+13 FOR ORAMRSF=1:1:$PIECE($GET(^ORAM(103,ORAMDFN,3,AROW,1,0)),"^",3)
SET COUNT=ORAMLOGN+ORAMRSF
SET ^ORAM(103,ORAMDFN,3,AROW,"LOG",COUNT,0)=^ORAM(103,ORAMDFN,3,AROW,1,ORAMRSF,0)
+14 SET ^ORAM(103,ORAMDFN,3,AROW,"LOG",0)="^^"_$GET(COUNT)_"^"_$GET(COUNT)_"^"_TODAY
+15 ;NOW SET NEW INFO FOR THE FLOW SHEET ENTRY
+16 ;Array order is: DFN;ARow;date;inr;ptnotified;twd;DUZ;#comment lines;comments
+17 SET ORAMNEWD=$GET(FSARRAY(2))
DO DT^DILF(,ORAMNEWD,.X)
SET ORAMNEWD=X
+18 SET $PIECE(^ORAM(103,ORAMDFN,3,AROW,0),"^")=$GET(ORAMNEWD)
SET $PIECE(^ORAM(103,ORAMDFN,3,AROW,0),"^",3)=$GET(FSARRAY(3))
SET $PIECE(^ORAM(103,ORAMDFN,3,AROW,0),"^",8)=$GET(FSARRAY(4))
SET $PIECE(^ORAM(103,ORAMDFN,3,AROW,0),"^",6)=$GET(FSARRAY(5))
+19 IF $GET(ORAMCOMP)=0
SET $PIECE(^ORAM(103,ORAMDFN,3,AROW,0),"^",2)=0
+20 SET $PIECE(^ORAM(103,ORAMDFN,3,AROW,0),"^",10)=$GET(FSARRAY(6))
SET $PIECE(^ORAM(103,ORAMDFN,3,AROW,0),"^",9)=TTIME
+21 IF $GET(FSARRAY(7))'=""
KILL ^ORAM(103,ORAMDFN,3,AROW,1)
FOR R=1:1:$GET(FSARRAY(7))
Begin DoDot:1
+22 SET ^ORAM(103,ORAMDFN,3,AROW,1,R,0)=$GET(FSARRAY(R+7))
End DoDot:1
+23 ;$E(ORAMDT,1,7)_"^"
SET ^ORAM(103,ORAMDFN,3,AROW,1,0)="^^"_$GET(FSARRAY(7))_"^"_$GET(FSARRAY(7))_"^"_TODAY_"^"
+24 SET ^ORAM(103,ORAMDFN,3,"B",$GET(ORAMNEWD),AROW)=""
+25 SET DIK="^ORAM(103,"
+26 SET DA(1)=ORAMDFN
SET DA=AROW
+27 DO IX^DIK
+28 SET RESULT=1
+29 QUIT
+30 ;
LOCK(RESULT,DATA) ; Locks form RPC=ORAM1 LOCK
+1 NEW X
+2 SET RESULT=0
+3 if $PIECE($GET(DATA),"^")=""
QUIT
+4 if $DATA(^ORAM(103,$PIECE(DATA,"^")))=0
QUIT
+5 DO NOW^%DTC
NEW ORAMTDAY
SET ORAMTDAY=X
+6 IF $PIECE(^ORAM(103,$PIECE(DATA,"^"),0),"^",18,19)=""
SET $PIECE(^ORAM(103,$PIECE(DATA,"^"),0),"^",18)="^"
+7 SET $PIECE(^ORAM(103,$PIECE(DATA,"^"),0),"^",19)=1_"|"_$PIECE(^VA(200,$PIECE(DATA,"^",2),0),"^")_"|"_ORAMTDAY
SET RESULT=1
+8 QUIT
+9 ;
UNLOCK(RESULT,DFN) ; Unlocks form RPC=ORAM1 UNLOCK
+1 SET RESULT=0
+2 if DFN<1
QUIT
+3 if $DATA(^ORAM(103,DFN))=0
QUIT
+4 SET $PIECE(^ORAM(103,DFN,0),"^",19)=0
SET RESULT=1
+5 QUIT
+6 ;
GETPT(RESULT) ; Get Pt list RPC=ORAM1 PT LIST
+1 NEW ORAMPT
+2 SET ORAMPT=0
FOR
SET ORAMPT=$ORDER(^ORAM(103,"B",ORAMPT))
if ORAMPT=""
QUIT
Begin DoDot:1
+3 SET RESULT($GET(ORAMPT))=$GET(ORAMPT)_"^"_$PIECE(^DPT(ORAMPT,0),"^")_"^"_$EXTRACT($PIECE(^DPT(ORAMPT,0),"^",9),6,9)
End DoDot:1
+4 QUIT
+5 ;
SETHCT(RESULT,ORAMORD) ; SET HCT LAB ITEM NUMBER
+1 if '+$GET(ORAMORD)
QUIT
+2 NEW ORAMX,ORAML60,ORAMCH
SET ORAMX=0
FOR
SET ORAMX=$ORDER(^ORD(101.43,$GET(ORAMORD),10,ORAMX))
if '+$GET(ORAMX)!+$GET(ORAMCH)
QUIT
Begin DoDot:1
+3 IF $PIECE(^ORD(101.43,$GET(ORAMORD),10,ORAMX,0),"^")["HCT"
SET ORAML60=+$PIECE(^(0),"^",2)
+4 IF +$GET(ORAML60)
SET ORAMCH=$PIECE($PIECE(^LAB(60,ORAML60,0),"^",5),";",2)
SET RESULT=ORAMCH
End DoDot:1
+5 QUIT
+6 ;
