ORAM3 ;POR/RSF - ANTICOAGULATION MANAGEMENT RPCS (4 of 4) ;12/09/09 14:44
;;3.0;ORDER ENTRY/RESULTS REPORTING;**307**;Dec 17, 1997;Build 60
;;Per VHA Directive 2004-038, this routine should not be modified
Q
;
PTADR(RESULT,ORAMDFN) ;GET PT ADDRESS
;;CALLED BY ORAM3 ADDRESS
N ORAMADD,ORAMADD2,ORAMADD3,ORAMCITY,ORAMCODE,ORAMST,ORAMZIP,ORAMBAD,ORAMT
S ORAMT=.11,ORAMST="",ORAMBAD=0
I '$G(ORAMDFN) S RESULT="NONE" Q
I $$TMPCHK(ORAMDFN)=1 S ORAMT=.121
S ORAMADD=$P($G(^DPT(ORAMDFN,ORAMT)),"^"),ORAMADD2=$P($G(^DPT(ORAMDFN,ORAMT)),"^",2),ORAMADD3=$P($G(^DPT(ORAMDFN,ORAMT)),"^",3)
S ORAMCITY=$P($G(^DPT(ORAMDFN,ORAMT)),"^",4),ORAMCODE=$P($G(^DPT(ORAMDFN,ORAMT)),"^",5),ORAMZIP=$P($G(^DPT(ORAMDFN,ORAMT)),"^",6),ORAMBAD=$P($G(^DPT(ORAMDFN,.11)),"^",16)
I ORAMCODE S ORAMST=$P($G(^DIC(5,$G(ORAMCODE),0)),"^",2)
S:$G(ORAMBAD)="" ORAMBAD=0
S RESULT=ORAMADD_"^"_ORAMADD2_"^"_ORAMADD3_"^"_ORAMCITY_"^"_ORAMST_"^"_ORAMZIP_"^"_$G(ORAMBAD)_"^"_$G(ORAMT)
Q
;
PTFONE(RESULT,ORAMDFN) ;GET PT PHONE NUMBERS
;;RPC=ORAM3 PHONE
;;RESULT=HOMEPHONE^WORKPHONE^CELLNUMBER^PAGER^EMAIL
N ORAMF1,ORAMF2,ORAMFC,ORAMP,ORAMEM,ORAMT S ORAMT=0
I '$G(ORAMDFN) S RESULT="NONE" Q
I $$TMPCHK(ORAMDFN)=1 S ORAMT=1
I ORAMT=0 D
. S ORAMF1=$P($G(^DPT(ORAMDFN,.13)),"^"),ORAMF2=$P($G(^DPT(ORAMDFN,.13)),"^",2)
. S ORAMFC=$P($G(^DPT(ORAMDFN,.13)),"^",4),ORAMP=$P($G(^DPT(ORAMDFN,.13)),"^",5),ORAMEM=$P($G(^DPT(ORAMDFN,.13)),"^",3)
I ORAMT=1 D
. S ORAMF1=$P($G(^DPT(ORAMDFN,.121)),"^",10),ORAMF2=$P($G(^DPT(ORAMDFN,.13)),"^",2)
. S ORAMFC=$P($G(^DPT(ORAMDFN,.13)),"^",4),ORAMP=$P($G(^DPT(ORAMDFN,.13)),"^",5),ORAMEM=$P($G(^DPT(ORAMDFN,.13)),"^",3)
S RESULT=$G(ORAMF1)_"^"_$G(ORAMF2)_"^"_$G(ORAMFC)_"^"_$G(ORAMP)_"^"_$G(ORAMEM)_"^"_$G(ORAMT)
Q
;
TMPCHK(ORAMDFN) ;
;;
N ORAMTMP S ORAMTMP=0
I $D(^DPT(ORAMDFN,.121)),$P(^DPT(ORAMDFN,.121),"^",9)="Y" D
. Q:$P(^DPT(ORAMDFN,.121),"^",7)>DT ;START DATE
. I $P(^DPT(ORAMDFN,.121),"^",8)'="" Q:DT>$P(^DPT(ORAMDFN,.121),"^",8) ;END DATE
. S ORAMTMP=1
Q ORAMTMP
;RSF 10/08/08 CHANGE TO CODE DUE TO NEWLY DISCOVERED PROBLEM WITH 'COMPLICATIONS'
COMPENT(RESULT,ORAMDFN,ORAMDUZ,ORAMC,ORAMCT,ORAMD2) ;
;RPC=ORAM3 COMPLICATION
Q:'+$G(ORAMDFN)
Q:'$G(ORAMDUZ)
Q:'+$G(ORAMC)
Q:$G(ORAMD2)=""
N ORAMD3,ORAMX D DT^DILF(,ORAMD2,.ORAMX) S ORAMD3=ORAMX
N ORAMNOW,ORAMDAY,X,% D NOW^%DTC S ORAMNOW=%,ORAMDAY=X
N ORAMNX S ORAMNX=$O(^ORAM(103,ORAMDFN,3," "),-1)+1
N ORAMC2,ORAMLLOC,ORAMPS,ORAMDD,ORAMTWD,ORAML,OERR
I '$G(ORAMNX) S ORAMNX=1
I ORAMNX>1 D
. S ORAML=ORAMNX-1,ORAMLLOC=$P(^ORAM(103,ORAMDFN,3,ORAML,0),"^",4),ORAMPS=$P(^(0),"^",5),ORAMTWD=$P(^(0),"^",6),ORAMDD=$P(^(0),"^",7)
I ORAMC>99 S ORAMC2=2 ;CLOT in the 100 range...I P1>100,P1#100>0 S P1=3 Q
I ORAMC#10>0 S ORAMC2=1 ;MAJOR BLEED I P1>99 S P1=2 Q
I ORAMC=10 S ORAMC2=3 ;MINOR BLEED
N DA,IENS,ORAMRSF,ORAMF
S IENS="+1,"_ORAMDFN_","
S DA=ORAMNX,DA(1)=ORAMDFN
S ORAMRSF(103.011,IENS,.01)=ORAMD3 ;COMPLICATION DATE
S ORAMRSF(103.011,IENS,30)=ORAMLLOC ;LAB DRAW LOC
S ORAMRSF(103.011,IENS,40)=ORAMPS ;PILL STRENGTH
S ORAMRSF(103.011,IENS,50)=ORAMTWD ;TOTAL WEEK DOSE
S ORAMRSF(103.011,IENS,60)=ORAMDD ;DAILY DOSING
S ORAMRSF(103.011,IENS,80)=ORAMNOW
S ORAMRSF(103.011,IENS,90)=ORAMDUZ ;PROVIDER
S ORAMRSF(103.011,IENS,104)=ORAMC2 ;COMPLICATION CODE
K ORAMF
S ORAMF(ORAMNX)=DA
K OERR
D UPDATE^DIE("","ORAMRSF","ORAMF","OERR")
S ^ORAM(103,ORAMDFN,3,ORAMNX,2,1,0)=ORAMD2
I $L(ORAMCT,"^")>0 N ORAMCC F ORAMCC=1:1:$L(ORAMCT,"^") D S ^ORAM(103,ORAMDFN,3,ORAMNX,2,0)="^^"_ORAMCC_"^"_ORAMCC_"^"_ORAMDAY_"^"
. S ^ORAM(103,ORAMDFN,3,ORAMNX,2,ORAMCC+1,0)=$P(ORAMCT,"^",ORAMCC)
S RESULT=1
Q
;
TLISTS ; Erases and sets Team Lists for Anticoagulation Clinics
; Option: ORAM SET TEAMS
N ORAMLIST ;ARRAYS OF TEAMS
D FTL(.ORAMLIST)
I '$D(ORAMLIST) Q ;No lists defined
D ETEAM(.ORAMLIST) ;ERASE ALL TEAM LISTS
D MTEAM(.ORAMLIST) ;FORM TODAY'S TEAM LISTS
Q
;
FTL(ORAMLIST) ;FIND TEAM LISTS CALLED FROM TLISTS
;
N ORAMI,ORAMCLST S ORAMI=0
D GETCLINS^ORAMSET(.ORAMCLST)
I +$G(ORAMCLST(0))'>0 Q ;Site not SET UP
; Loop through Clinics, get team lists for each
F S ORAMI=$O(ORAMCLST(ORAMI)) Q:+ORAMI'>0 D
. N ORAMCL,ORAMALL,ORAMCPLX
. S ORAMCL=$P($G(ORAMCLST(ORAMI)),U,2) Q:+ORAMCL'>0
. S ORAMALL=$$GET^XPAR(ORAMCL,"ORAM TEAM LIST (ALL)",1,"I")
. S:ORAMALL]"" ORAMLIST(ORAMCL,"ALL")=ORAMALL
. S ORAMCPLX=$$GET^XPAR(ORAMCL,"ORAM TEAM LIST (COMPLEX)",1,"I")
. S:ORAMCPLX]"" ORAMLIST(ORAMCL,"COMPLEX")=ORAMCPLX
Q
;
ETEAM(ORAMLIST) ; Remove all Anticoagulation Patients from their respective lists
; called from TLISTS
N ORAMI S ORAMI=""
F S ORAMI=$O(ORAMLIST(ORAMI)) Q:ORAMI']"" D
. N ORAML S ORAML=""
. F S ORAML=$O(ORAMLIST(ORAMI,ORAML)) Q:ORAML']"" D
. . N DO,DA,DIK
. . S DA(1)=ORAMLIST(ORAMI,ORAML),DIK="^OR(100.21"_","_DA(1)_",10,"
. . S DA=0 F S DA=$O(^OR(100.21,DA(1),10,DA)) Q:+DA'>0 D
. . . D ^DIK
Q
;
MTEAM(ORAMLIST) ; Build Today's Team Lists
; CALLED FROM TLISTS
N ORAMCL S ORAMCL=""
; Loop through ORAMLIST by clinic location
F S ORAMCL=$O(ORAMLIST(ORAMCL)) Q:ORAMCL']"" D
. N ORAMCN,ORAMCA,ORAMCC,ORAMDFN
. S ORAMCN=+ORAMCL ; Pointer to file 44
. S ORAMCA=$G(ORAMLIST(ORAMCL,"ALL")) ; Pointer to "All" List
. S ORAMCC=$G(ORAMLIST(ORAMCL,"COMPLEX")) ; Pointer to "Complex" List
. ; Loop through Anticoagulation Patients by location
. S ORAMDFN=0
. F S ORAMDFN=$O(^ORAM(103,"CL",ORAMCN,ORAMDFN)) Q:+ORAMDFN'>0 D
. . N ORAMD0,ORAMRDT,ORAMCPLX,ORAMNDCB,ORAMAXDT
. . S ORAMD0=$G(^ORAM(103,ORAMDFN,0))
. . S ORAMRDT=$P(ORAMD0,U,4) ; Pt's Return Date
. . S ORAMAXDT=DT_".2359" ; Upper bound for return date range
. . S ORAMCPLX=$P(ORAMD0,U,10) ; Pt's Complexity
. . S ORAMNDCB=$P(ORAMD0,U,20) ; Next Day Callback
. . ; if next day callback, increment return date, disregard time
. . I +ORAMNDCB S ORAMRDT=$$FMADD^XLFDT($P(ORAMRDT,"."),1)
. . ; if future return date or pt inactive, quit to next pt
. . I (ORAMRDT>ORAMAXDT)!(ORAMCPLX=2) Q
. . ; otherwise, add pt to appropriate list(s) for location
. . D ADDLIST(ORAMDFN,ORAMCA) ; All active pts on "ALL" List
. . I ORAMCPLX=1 D ADDLIST(ORAMDFN,ORAMCC) ; Complex pts also on "COMPLEX" List
Q
ADDLIST(ORAMDFN,ORAMLDA) ; Add pt to Team List / Assure record is UNLOCKED
N DIC,DA,DO,X,ORAMLR
S X=ORAMDFN_";DPT("
S DA(1)=ORAMLDA,DIC="^OR(100.21"_","_DA(1)_",10,",DIC(0)="L" D FILE^DICN
D UNLOCK^ORAM1(.ORAMLR,ORAMDFN)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORAM3 6539 printed Apr 09, 2024@21:27 Page 2
ORAM3 ;POR/RSF - ANTICOAGULATION MANAGEMENT RPCS (4 of 4) ;12/09/09 14:44
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**307**;Dec 17, 1997;Build 60
+2 ;;Per VHA Directive 2004-038, this routine should not be modified
+3 QUIT
+4 ;
PTADR(RESULT,ORAMDFN) ;GET PT ADDRESS
+1 ;;CALLED BY ORAM3 ADDRESS
+2 NEW ORAMADD,ORAMADD2,ORAMADD3,ORAMCITY,ORAMCODE,ORAMST,ORAMZIP,ORAMBAD,ORAMT
+3 SET ORAMT=.11
SET ORAMST=""
SET ORAMBAD=0
+4 IF '$GET(ORAMDFN)
SET RESULT="NONE"
QUIT
+5 IF $$TMPCHK(ORAMDFN)=1
SET ORAMT=.121
+6 SET ORAMADD=$PIECE($GET(^DPT(ORAMDFN,ORAMT)),"^")
SET ORAMADD2=$PIECE($GET(^DPT(ORAMDFN,ORAMT)),"^",2)
SET ORAMADD3=$PIECE($GET(^DPT(ORAMDFN,ORAMT)),"^",3)
+7 SET ORAMCITY=$PIECE($GET(^DPT(ORAMDFN,ORAMT)),"^",4)
SET ORAMCODE=$PIECE($GET(^DPT(ORAMDFN,ORAMT)),"^",5)
SET ORAMZIP=$PIECE($GET(^DPT(ORAMDFN,ORAMT)),"^",6)
SET ORAMBAD=$PIECE($GET(^DPT(ORAMDFN,.11)),"^",16)
+8 IF ORAMCODE
SET ORAMST=$PIECE($GET(^DIC(5,$GET(ORAMCODE),0)),"^",2)
+9 if $GET(ORAMBAD)=""
SET ORAMBAD=0
+10 SET RESULT=ORAMADD_"^"_ORAMADD2_"^"_ORAMADD3_"^"_ORAMCITY_"^"_ORAMST_"^"_ORAMZIP_"^"_$GET(ORAMBAD)_"^"_$GET(ORAMT)
+11 QUIT
+12 ;
PTFONE(RESULT,ORAMDFN) ;GET PT PHONE NUMBERS
+1 ;;RPC=ORAM3 PHONE
+2 ;;RESULT=HOMEPHONE^WORKPHONE^CELLNUMBER^PAGER^EMAIL
+3 NEW ORAMF1,ORAMF2,ORAMFC,ORAMP,ORAMEM,ORAMT
SET ORAMT=0
+4 IF '$GET(ORAMDFN)
SET RESULT="NONE"
QUIT
+5 IF $$TMPCHK(ORAMDFN)=1
SET ORAMT=1
+6 IF ORAMT=0
Begin DoDot:1
+7 SET ORAMF1=$PIECE($GET(^DPT(ORAMDFN,.13)),"^")
SET ORAMF2=$PIECE($GET(^DPT(ORAMDFN,.13)),"^",2)
+8 SET ORAMFC=$PIECE($GET(^DPT(ORAMDFN,.13)),"^",4)
SET ORAMP=$PIECE($GET(^DPT(ORAMDFN,.13)),"^",5)
SET ORAMEM=$PIECE($GET(^DPT(ORAMDFN,.13)),"^",3)
End DoDot:1
+9 IF ORAMT=1
Begin DoDot:1
+10 SET ORAMF1=$PIECE($GET(^DPT(ORAMDFN,.121)),"^",10)
SET ORAMF2=$PIECE($GET(^DPT(ORAMDFN,.13)),"^",2)
+11 SET ORAMFC=$PIECE($GET(^DPT(ORAMDFN,.13)),"^",4)
SET ORAMP=$PIECE($GET(^DPT(ORAMDFN,.13)),"^",5)
SET ORAMEM=$PIECE($GET(^DPT(ORAMDFN,.13)),"^",3)
End DoDot:1
+12 SET RESULT=$GET(ORAMF1)_"^"_$GET(ORAMF2)_"^"_$GET(ORAMFC)_"^"_$GET(ORAMP)_"^"_$GET(ORAMEM)_"^"_$GET(ORAMT)
+13 QUIT
+14 ;
TMPCHK(ORAMDFN) ;
+1 ;;
+2 NEW ORAMTMP
SET ORAMTMP=0
+3 IF $DATA(^DPT(ORAMDFN,.121))
IF $PIECE(^DPT(ORAMDFN,.121),"^",9)="Y"
Begin DoDot:1
+4 ;START DATE
if $PIECE(^DPT(ORAMDFN,.121),"^",7)>DT
QUIT
+5 ;END DATE
IF $PIECE(^DPT(ORAMDFN,.121),"^",8)'=""
if DT>$PIECE(^DPT(ORAMDFN,.121),"^",8)
QUIT
+6 SET ORAMTMP=1
End DoDot:1
+7 QUIT ORAMTMP
+8 ;RSF 10/08/08 CHANGE TO CODE DUE TO NEWLY DISCOVERED PROBLEM WITH 'COMPLICATIONS'
COMPENT(RESULT,ORAMDFN,ORAMDUZ,ORAMC,ORAMCT,ORAMD2) ;
+1 ;RPC=ORAM3 COMPLICATION
+2 if '+$GET(ORAMDFN)
QUIT
+3 if '$GET(ORAMDUZ)
QUIT
+4 if '+$GET(ORAMC)
QUIT
+5 if $GET(ORAMD2)=""
QUIT
+6 NEW ORAMD3,ORAMX
DO DT^DILF(,ORAMD2,.ORAMX)
SET ORAMD3=ORAMX
+7 NEW ORAMNOW,ORAMDAY,X,%
DO NOW^%DTC
SET ORAMNOW=%
SET ORAMDAY=X
+8 NEW ORAMNX
SET ORAMNX=$ORDER(^ORAM(103,ORAMDFN,3," "),-1)+1
+9 NEW ORAMC2,ORAMLLOC,ORAMPS,ORAMDD,ORAMTWD,ORAML,OERR
+10 IF '$GET(ORAMNX)
SET ORAMNX=1
+11 IF ORAMNX>1
Begin DoDot:1
+12 SET ORAML=ORAMNX-1
SET ORAMLLOC=$PIECE(^ORAM(103,ORAMDFN,3,ORAML,0),"^",4)
SET ORAMPS=$PIECE(^(0),"^",5)
SET ORAMTWD=$PIECE(^(0),"^",6)
SET ORAMDD=$PIECE(^(0),"^",7)
End DoDot:1
+13 ;CLOT in the 100 range...I P1>100,P1#100>0 S P1=3 Q
IF ORAMC>99
SET ORAMC2=2
+14 ;MAJOR BLEED I P1>99 S P1=2 Q
IF ORAMC#10>0
SET ORAMC2=1
+15 ;MINOR BLEED
IF ORAMC=10
SET ORAMC2=3
+16 NEW DA,IENS,ORAMRSF,ORAMF
+17 SET IENS="+1,"_ORAMDFN_","
+18 SET DA=ORAMNX
SET DA(1)=ORAMDFN
+19 ;COMPLICATION DATE
SET ORAMRSF(103.011,IENS,.01)=ORAMD3
+20 ;LAB DRAW LOC
SET ORAMRSF(103.011,IENS,30)=ORAMLLOC
+21 ;PILL STRENGTH
SET ORAMRSF(103.011,IENS,40)=ORAMPS
+22 ;TOTAL WEEK DOSE
SET ORAMRSF(103.011,IENS,50)=ORAMTWD
+23 ;DAILY DOSING
SET ORAMRSF(103.011,IENS,60)=ORAMDD
+24 SET ORAMRSF(103.011,IENS,80)=ORAMNOW
+25 ;PROVIDER
SET ORAMRSF(103.011,IENS,90)=ORAMDUZ
+26 ;COMPLICATION CODE
SET ORAMRSF(103.011,IENS,104)=ORAMC2
+27 KILL ORAMF
+28 SET ORAMF(ORAMNX)=DA
+29 KILL OERR
+30 DO UPDATE^DIE("","ORAMRSF","ORAMF","OERR")
+31 SET ^ORAM(103,ORAMDFN,3,ORAMNX,2,1,0)=ORAMD2
+32 IF $LENGTH(ORAMCT,"^")>0
NEW ORAMCC
FOR ORAMCC=1:1:$LENGTH(ORAMCT,"^")
Begin DoDot:1
+33 SET ^ORAM(103,ORAMDFN,3,ORAMNX,2,ORAMCC+1,0)=$PIECE(ORAMCT,"^",ORAMCC)
End DoDot:1
SET ^ORAM(103,ORAMDFN,3,ORAMNX,2,0)="^^"_ORAMCC_"^"_ORAMCC_"^"_ORAMDAY_"^"
+34 SET RESULT=1
+35 QUIT
+36 ;
TLISTS ; Erases and sets Team Lists for Anticoagulation Clinics
+1 ; Option: ORAM SET TEAMS
+2 ;ARRAYS OF TEAMS
NEW ORAMLIST
+3 DO FTL(.ORAMLIST)
+4 ;No lists defined
IF '$DATA(ORAMLIST)
QUIT
+5 ;ERASE ALL TEAM LISTS
DO ETEAM(.ORAMLIST)
+6 ;FORM TODAY'S TEAM LISTS
DO MTEAM(.ORAMLIST)
+7 QUIT
+8 ;
FTL(ORAMLIST) ;FIND TEAM LISTS CALLED FROM TLISTS
+1 ;
+2 NEW ORAMI,ORAMCLST
SET ORAMI=0
+3 DO GETCLINS^ORAMSET(.ORAMCLST)
+4 ;Site not SET UP
IF +$GET(ORAMCLST(0))'>0
QUIT
+5 ; Loop through Clinics, get team lists for each
+6 FOR
SET ORAMI=$ORDER(ORAMCLST(ORAMI))
if +ORAMI'>0
QUIT
Begin DoDot:1
+7 NEW ORAMCL,ORAMALL,ORAMCPLX
+8 SET ORAMCL=$PIECE($GET(ORAMCLST(ORAMI)),U,2)
if +ORAMCL'>0
QUIT
+9 SET ORAMALL=$$GET^XPAR(ORAMCL,"ORAM TEAM LIST (ALL)",1,"I")
+10 if ORAMALL]""
SET ORAMLIST(ORAMCL,"ALL")=ORAMALL
+11 SET ORAMCPLX=$$GET^XPAR(ORAMCL,"ORAM TEAM LIST (COMPLEX)",1,"I")
+12 if ORAMCPLX]""
SET ORAMLIST(ORAMCL,"COMPLEX")=ORAMCPLX
End DoDot:1
+13 QUIT
+14 ;
ETEAM(ORAMLIST) ; Remove all Anticoagulation Patients from their respective lists
+1 ; called from TLISTS
+2 NEW ORAMI
SET ORAMI=""
+3 FOR
SET ORAMI=$ORDER(ORAMLIST(ORAMI))
if ORAMI']""
QUIT
Begin DoDot:1
+4 NEW ORAML
SET ORAML=""
+5 FOR
SET ORAML=$ORDER(ORAMLIST(ORAMI,ORAML))
if ORAML']""
QUIT
Begin DoDot:2
+6 NEW DO,DA,DIK
+7 SET DA(1)=ORAMLIST(ORAMI,ORAML)
SET DIK="^OR(100.21"_","_DA(1)_",10,"
+8 SET DA=0
FOR
SET DA=$ORDER(^OR(100.21,DA(1),10,DA))
if +DA'>0
QUIT
Begin DoDot:3
+9 DO ^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
MTEAM(ORAMLIST) ; Build Today's Team Lists
+1 ; CALLED FROM TLISTS
+2 NEW ORAMCL
SET ORAMCL=""
+3 ; Loop through ORAMLIST by clinic location
+4 FOR
SET ORAMCL=$ORDER(ORAMLIST(ORAMCL))
if ORAMCL']""
QUIT
Begin DoDot:1
+5 NEW ORAMCN,ORAMCA,ORAMCC,ORAMDFN
+6 ; Pointer to file 44
SET ORAMCN=+ORAMCL
+7 ; Pointer to "All" List
SET ORAMCA=$GET(ORAMLIST(ORAMCL,"ALL"))
+8 ; Pointer to "Complex" List
SET ORAMCC=$GET(ORAMLIST(ORAMCL,"COMPLEX"))
+9 ; Loop through Anticoagulation Patients by location
+10 SET ORAMDFN=0
+11 FOR
SET ORAMDFN=$ORDER(^ORAM(103,"CL",ORAMCN,ORAMDFN))
if +ORAMDFN'>0
QUIT
Begin DoDot:2
+12 NEW ORAMD0,ORAMRDT,ORAMCPLX,ORAMNDCB,ORAMAXDT
+13 SET ORAMD0=$GET(^ORAM(103,ORAMDFN,0))
+14 ; Pt's Return Date
SET ORAMRDT=$PIECE(ORAMD0,U,4)
+15 ; Upper bound for return date range
SET ORAMAXDT=DT_".2359"
+16 ; Pt's Complexity
SET ORAMCPLX=$PIECE(ORAMD0,U,10)
+17 ; Next Day Callback
SET ORAMNDCB=$PIECE(ORAMD0,U,20)
+18 ; if next day callback, increment return date, disregard time
+19 IF +ORAMNDCB
SET ORAMRDT=$$FMADD^XLFDT($PIECE(ORAMRDT,"."),1)
+20 ; if future return date or pt inactive, quit to next pt
+21 IF (ORAMRDT>ORAMAXDT)!(ORAMCPLX=2)
QUIT
+22 ; otherwise, add pt to appropriate list(s) for location
+23 ; All active pts on "ALL" List
DO ADDLIST(ORAMDFN,ORAMCA)
+24 ; Complex pts also on "COMPLEX" List
IF ORAMCPLX=1
DO ADDLIST(ORAMDFN,ORAMCC)
End DoDot:2
End DoDot:1
+25 QUIT
ADDLIST(ORAMDFN,ORAMLDA) ; Add pt to Team List / Assure record is UNLOCKED
+1 NEW DIC,DA,DO,X,ORAMLR
+2 SET X=ORAMDFN_";DPT("
+3 SET DA(1)=ORAMLDA
SET DIC="^OR(100.21"_","_DA(1)_",10,"
SET DIC(0)="L"
DO FILE^DICN
+4 DO UNLOCK^ORAM1(.ORAMLR,ORAMDFN)
+5 QUIT
