RAUTL10 ;HISC/CAH,FPT,GJC-Utility Routine ;7/23/97 11:05
;;5.0;Radiology/Nuclear Medicine;**28**;Mar 16, 1998
;
UPDLOC ;Update Pt Loc Info, file 74.4
;RAY3= 0 node of 74.4, RAB= IEN of 74.3, RARDIFN= IEN of 74.4
N RAY I '$D(^RARPT(RARPT,0)) Q
I $P(^RARPT(RARPT,0),U,11) S RAPRTOK=1 Q
S RAI="",RAI1=$S($D(^DPT(RADFN,.1)):^(.1),1:0) S:RAI1="" RAI1=0 S RAI=$O(^DIC(42,"B",RAI1,0)) S:'$D(RABTY) RABTY="ALL"
I '$P(RAY3,U,6),'$P(RAY3,U,8),RAB=$$DQ("FILE ROOM") S RAPRTOK=1 G SET
I $P(RAY3,U,6),$P(RAY3,U,6)=RAI S RAPRTOK=1 G SET
I $P(RAY3,U,8),'RAI S RAPRTOK=1 G SET
I $P(RAY3,U,6),'RAI S $P(RAY3,U,6)="" S RAY=$$DQ("FILE ROOM") D:'$D(RAFL) UP2(0) S:'RAY RAPRTOK=1 S:RAY=RAB&((RAI1=RABTY)!(RABTY="ALL")) RAPRTOK=1 G SET
I $P(RAY3,U,6),$P(RAY3,U,6)'=RAI S $P(RAY3,U,6)=RAI D:'$D(RAFL) UP2(1) S:RAI1=RABTY!(RABTY="ALL") RAPRTOK=1 G SET
I $P(RAY3,U,8),RAI S $P(RAY3,U,8)="",$P(RAY3,U,6)=RAI S RAY=$$DQ("WARD REPORTS") D:'$D(RAFL) UP2(2) S:RAY=RAB!('RAY) RAPRTOK=1
SET I $D(RAPRTF),$D(RAPRTOK) S $P(^RARPT(RARPT,0),U,11)=DT
K RAI,RAI1 Q
;
UP2(RAX) ;update file - 74.4
;INPUT: RAX (required)
; If RAX=0, inpt to outpt/RAX=1, ward transfer/RAX=2, outpt to inpt
;OUTPUT: If being called from RARTST2 and patient has been discharged,
; the variable RARTST2I will be defined and will contain the IEN of
; the altered File Room record in file 74.4.
N RABI,RABTCH,RADQ,DA,DIE,DR,DC S (RADQ("FROM"),RADQ("TO"))=0
S:RAX=0 RADQ("FROM")=$$DQ("WARD REPORTS"),RADQ("TO")=$$DQ("FILE ROOM")
S:RAX=2 RADQ("FROM")=$$DQ("CLINIC REPORTS"),RADQ("TO")=$$DQ("WARD REPORTS")
I RAX'=1 S RABI=0 F S RABI=$O(^RABTCH(74.4,"B",RARPT,RABI)) Q:'RABI S RABTCH=+$P($G(^RABTCH(74.4,RABI,0)),U,11) S:RABTCH=RADQ("FROM") $P(RADQ("FROM"),U,2)=RABI S:RABTCH=RADQ("TO") $P(RADQ("TO"),U,2)=RABI
I RAX=0,$P(RADQ("FROM"),U,2),$P(RADQ("TO"),U,2) S DIK="^RABTCH(74.4,",DA=$P(RADQ("TO"),U,2) D ^DIK K DIK I $D(RARTST2) D
.;If file room entry in file 74.4 was deleted, and this is a discharged
.;patient (i.e. RAX=0), and UPDLOC is being called from RARTST2 (i.e.
.;RARTST2 is defined), set RARTST2I to IEN of remaining 74.4 entry that
.;will be edited below to point to File Room.
.;This fix was added so RARTST2 can properly update 'Date Printed' on
.;the 74.4 entry for File Room for discharged patients. Otherwise,
.;File Room entries would print twice before being removed from queue.
. I $$DQ("FILE ROOM")=$P(RADQ("TO"),U,1),'$D(^RABTCH(74.4,+$P(RADQ("TO"),U,2),0)) S RARTST2I=+$P(RADQ("FROM"),U,2)
I RAX=2,'+RADQ("TO"),$P(RADQ("FROM"),U,2) S DIK="^RABTCH(74.4,",DA=$P(RADQ("FROM"),U,2) D ^DIK K DIK
S DR=$S(+RADQ("TO")&($P(RADQ("FROM"),U,2)):"11////^S X=+RADQ(""TO"")",1:"")
S DIE="^RABTCH(74.4,",DR="I RAX>0 S Y=""@1"";6///@;S Y=""@2"";@1;6////^S X=RAI;@2;S:RAX=0 Y=""@3"" S:RAX=1 Y="""";8///@;@3;S:DA'=$P($G(RADQ(""FROM"")),U,2) Y="""";"_DR
S DA=0 F S DA=$O(^RABTCH(74.4,"B",RARPT,DA)) Q:'DA D LOCK,^DIE L -^RABTCH(74.4,DA,0)
K DA,DIE,DR,DE,DQ Q
DQ(X) ;distr queue
;INPUT: queue name
;OUTPUT: IEN in distr queue (74.3) or 0
S X=+$O(^RABTCH(74.3,"B",X,0))
Q $S('X:0,+$G(^RABTCH(74.3,X,"I")):0,1:X)
LOCK L +^RABTCH(74.4,DA,0):2 I '$T G LOCK
Q
STR70(RA0,RA1,RA2,RA3) ;
S RA0=""
Q:'$O(^RADPT(RA1,"DT",RA2,"P",RA3,"M","B",0))
M RA0=^RADPT(RA1,"DT",RA2,"P",RA3,"M","B")
D STR(.RA0)
Q
STR751(RA0,RAOIFN) ;
S RA0=""
Q:'$O(^RAO(75.1,RAOIFN,"M","B",0))
M RA0=^RAO(75.1,RAOIFN,"M","B")
D STR(.RA0)
Q
STR(RA0) ;
N I S I=""
F S I=$O(RA0(I)) Q:'I S RA0=RA0_I_","
Q
RAUTL10 ;HISC/CAH,FPT,GJC-Utility Routine ;7/23/97 11:05
+1 ;;5.0;Radiology/Nuclear Medicine;**28**;Mar 16, 1998
+2 ;
UPDLOC ;Update Pt Loc Info, file 74.4
+1 ;RAY3= 0 node of 74.4, RAB= IEN of 74.3, RARDIFN= IEN of 74.4
+2 NEW RAY
IF '$DATA(^RARPT(RARPT,0))
QUIT
+3 IF $PIECE(^RARPT(RARPT,0),U,11)
SET RAPRTOK=1
QUIT
+4 SET RAI=""
SET RAI1=$SELECT($DATA(^DPT(RADFN,.1)):^(.1),1:0)
IF RAI1=""
SET RAI1=0
SET RAI=$ORDER(^DIC(42,"B",RAI1,0))
IF '$DATA(RABTY)
SET RABTY="ALL"
+5 IF '$PIECE(RAY3,U,6)
IF '$PIECE(RAY3,U,8)
IF RAB=$$DQ("FILE ROOM")
SET RAPRTOK=1
GOTO SET
+6 IF $PIECE(RAY3,U,6)
IF $PIECE(RAY3,U,6)=RAI
SET RAPRTOK=1
GOTO SET
+7 IF $PIECE(RAY3,U,8)
IF 'RAI
SET RAPRTOK=1
GOTO SET
+8 IF $PIECE(RAY3,U,6)
IF 'RAI
SET $PIECE(RAY3,U,6)=""
SET RAY=$$DQ("FILE ROOM")
IF '$DATA(RAFL)
DO UP2(0)
IF 'RAY
SET RAPRTOK=1
IF RAY=RAB&((RAI1=RABTY)!(RABTY="ALL"))
SET RAPRTOK=1
GOTO SET
+9 IF $PIECE(RAY3,U,6)
IF $PIECE(RAY3,U,6)'=RAI
SET $PIECE(RAY3,U,6)=RAI
IF '$DATA(RAFL)
DO UP2(1)
IF RAI1=RABTY!(RABTY="ALL")
SET RAPRTOK=1
GOTO SET
+10 IF $PIECE(RAY3,U,8)
IF RAI
SET $PIECE(RAY3,U,8)=""
SET $PIECE(RAY3,U,6)=RAI
SET RAY=$$DQ("WARD REPORTS")
IF '$DATA(RAFL)
DO UP2(2)
IF RAY=RAB!('RAY)
SET RAPRTOK=1
SET IF $DATA(RAPRTF)
IF $DATA(RAPRTOK)
SET $PIECE(^RARPT(RARPT,0),U,11)=DT
+1 KILL RAI,RAI1
QUIT
+2 ;
UP2(RAX) ;update file - 74.4
+1 ;INPUT: RAX (required)
+2 ; If RAX=0, inpt to outpt/RAX=1, ward transfer/RAX=2, outpt to inpt
+3 ;OUTPUT: If being called from RARTST2 and patient has been discharged,
+4 ; the variable RARTST2I will be defined and will contain the IEN of
+5 ; the altered File Room record in file 74.4.
+6 NEW RABI,RABTCH,RADQ,DA,DIE,DR,DC
SET (RADQ("FROM"),RADQ("TO"))=0
+7 IF RAX=0
SET RADQ("FROM")=$$DQ("WARD REPORTS")
SET RADQ("TO")=$$DQ("FILE ROOM")
+8 IF RAX=2
SET RADQ("FROM")=$$DQ("CLINIC REPORTS")
SET RADQ("TO")=$$DQ("WARD REPORTS")
+9 IF RAX'=1
SET RABI=0
FOR
SET RABI=$ORDER(^RABTCH(74.4,"B",RARPT,RABI))
IF 'RABI
QUIT
SET RABTCH=+$PIECE($GET(^RABTCH(74.4,RABI,0)),U,11)
IF RABTCH=RADQ("FROM")
SET $PIECE(RADQ("FROM"),U,2)=RABI
IF RABTCH=RADQ("TO")
SET $PIECE(RADQ("TO"),U,2)=RABI
+10 IF RAX=0
IF $PIECE(RADQ("FROM"),U,2)
IF $PIECE(RADQ("TO"),U,2)
SET DIK="^RABTCH(74.4,"
SET DA=$PIECE(RADQ("TO"),U,2)
DO ^DIK
KILL DIK
IF $DATA(RARTST2)
Begin DoDot:1
+11 ;If file room entry in file 74.4 was deleted, and this is a discharged
+12 ;patient (i.e. RAX=0), and UPDLOC is being called from RARTST2 (i.e.
+13 ;RARTST2 is defined), set RARTST2I to IEN of remaining 74.4 entry that
+14 ;will be edited below to point to File Room.
+15 ;This fix was added so RARTST2 can properly update 'Date Printed' on
+16 ;the 74.4 entry for File Room for discharged patients. Otherwise,
+17 ;File Room entries would print twice before being removed from queue.
+18 IF $$DQ("FILE ROOM")=$PIECE(RADQ("TO"),U,1)
IF '$DATA(^RABTCH(74.4,+$PIECE(RADQ("TO"),U,2),0))
SET RARTST2I=+$PIECE(RADQ("FROM"),U,2)
End DoDot:1
+19 IF RAX=2
IF '+RADQ("TO")
IF $PIECE(RADQ("FROM"),U,2)
SET DIK="^RABTCH(74.4,"
SET DA=$PIECE(RADQ("FROM"),U,2)
DO ^DIK
KILL DIK
+20 SET DR=$SELECT(+RADQ("TO")&($PIECE(RADQ("FROM"),U,2)):"11////^S X=+RADQ(""TO"")",1:"")
+21 SET DIE="^RABTCH(74.4,"
SET DR="I RAX>0 S Y=""@1"";6///@;S Y=""@2"";@1;6////^S X=RAI;@2;S:RAX=0 Y=""@3"" S:RAX=1 Y="""";8///@;@3;S:DA'=$P($G(RADQ(""FROM"")),U,2) Y="""";"_DR
+22 SET DA=0
FOR
SET DA=$ORDER(^RABTCH(74.4,"B",RARPT,DA))
IF 'DA
QUIT
DO LOCK
DO ^DIE
LOCK -^RABTCH(74.4,DA,0)
+23 KILL DA,DIE,DR,DE,DQ
QUIT
DQ(X) ;distr queue
+1 ;INPUT: queue name
+2 ;OUTPUT: IEN in distr queue (74.3) or 0
+3 SET X=+$ORDER(^RABTCH(74.3,"B",X,0))
+4 QUIT $SELECT('X:0,+$GET(^RABTCH(74.3,X,"I")):0,1:X)
LOCK LOCK +^RABTCH(74.4,DA,0):2
IF '$TEST
GOTO LOCK
+1 QUIT
STR70(RA0,RA1,RA2,RA3) ;
+1 SET RA0=""
+2 IF '$ORDER(^RADPT(RA1,"DT",RA2,"P",RA3,"M","B",0))
QUIT
+3 MERGE RA0=^RADPT(RA1,"DT",RA2,"P",RA3,"M","B")
+4 DO STR(.RA0)
+5 QUIT
STR751(RA0,RAOIFN) ;
+1 SET RA0=""
+2 IF '$ORDER(^RAO(75.1,RAOIFN,"M","B",0))
QUIT
+3 MERGE RA0=^RAO(75.1,RAOIFN,"M","B")
+4 DO STR(.RA0)
+5 QUIT
STR(RA0) ;
+1 NEW I
SET I=""
+2 FOR
SET I=$ORDER(RA0(I))
IF 'I
QUIT
SET RA0=RA0_I_","
+3 QUIT
