RTUTL1 ;MJK,PKE/ISC-ALBANY-Utility Routine; ; 4/24/87 9:22 AM ;
;;v 2.0;Record Tracking;;10/22/91
MOVE Q:'$D(^RT(RT,"CL")) S RTM=^("CL"),X1=+RTM,$P(RTM,"^",1,4)=RT_"^^^" I $D(^RTV(190.1,X1,0)) S $P(RTM,"^",2,4)=$P(^(0),"^",2,4)
S I=+$P(^RTV(190.3,0),"^",3)
LOC S I1=I,I=$O(^RTV(190.3,I)) IF I1+1=I G LOC
L +^RTV(190.3,I1+1):1 IF '$T!(I1=999)!($D(^(I1+1,0))) L -^RTV(190.3,I1+1) S I=I1+1 S:$L(I)=4 I=9999 G LOC
S I=I1+1
S ^RTV(190.3,I,0)=RT,^RTV(190.3,"B",RT,I)="",^(0)=$P(^RTV(190.3,0),"^",1,2)_"^"_I_"^"_($P(^(0),"^",4)+1),^DISV($S($D(DUZ)'[0:DUZ,1:0),"^RTV(190.3,")=I L -^RTV(190.3,I1+1)
S (DA,RTLAST)=I,DIE="^RTV(190.3,",DR="[RT MOVEMENT]" D ^DIE K DE,DQ,RTLAST,RTM,X,X1,I,I1 Q
;
ARRAY F I=0:0 S I=$O(RTY(I)) Q:'I S Y=+RTY(I) D ARRAY1
K I Q
ARRAY1 I $D(RTDEL),'$D(^TMP($J,"RT","XREF",+Y)) W !?3,*7,"...not on list to be processed" Q
I $D(RTDEL) K ^TMP($J,"RT","AR",+^(+Y)),^TMP($J,"RT","XREF",+Y) S RTN=RTN-1 W !?3,"...deleted from list to be "_$S($D(Y("M")):Y("M"),1:"processed") K Y Q
I $D(^TMP($J,"RT","XREF",+Y)) W !?3,*7,"...already selected" K Y Q
S RTN=RTN+1,^TMP($J,"RT","AR",RTN)=Y,^TMP($J,"RT","XREF",+Y)=RTN W !?3,"...added to list to be "_$S($D(Y("M")):Y("M"),1:"processed") Q
;
DEMOS Q:'$D(^RT(RT,0)) S Y=^(0),RTD("V")=$P(Y,"^",7),RTD("T")=$S($D(^DIC(195.2,+$P(Y,"^",3),0)):$P(^(0),"^"),1:"UNKNOWN")_" (V"_+$P(Y,"^",7)_") " S RTD("A")=$S($D(^(0)):$P(^(0),"^",2),1:"UNK"),Y=$P(Y,"^")
DEMOS1 S N=Y D NAME^RTB S RTD("N")=Y
I $P(N,";",2)="DPT(",$D(^DPT(+N,0)) S Y=^(0),Y1=$P(Y,"^",9),RTD("SSN")=$E(Y1,1,3)_"-"_$E(Y1,4,5)_"-"_$E(Y1,6,10),Y=$P(Y,"^",3) D D^DIQ:Y S RTD("DOB")=Y S:$D(^(.1)) RTD("W")=^(.1) I $D(^(.35)) S Y=+$P(^(.35),".") I Y D D^DIQ S RTD("DOD")=Y
DEMOS2 S Y="" I $D(RT),$D(^RT(+RT,"CL")) S Y=^("CL")
DEMOS3 S Y2=Y,Y1=$S($D(^RTV(195.9,+$P(Y,"^",5),0)):^(0),1:""),RTD("P")=$P(Y1,"^",8),RTD("L")=$P(Y1,"^",9),RTD("P1")=$P(Y1,"^",7),Y=+$E($P(Y,"^",6),1,12) D D^DIQ:Y S RTD("D")=Y,Y=$P(Y1,"^") D NAME^RTB S RTD("B")=Y
I $D(^RTV(195.9,+$P(Y2,"^",14),0)) S Y=^(0),RTD("PROVP")=$P(Y,"^",8),RTD("PROVL")=$P(Y,"^",9),Y=$P(Y,"^") D NAME^RTB S RTD("PROV")=Y
K Y,Y1,Y2 Q
;
DISP ;Executed by the ^DD(190,0,"ID","WRITE") node
S RTZ1="Y^RT" D SAVE S RT=+Y D DEMOS W:$X>50 ! W ?50," Type: ",$E(RTD("T"),1,22) W:$D(RTD("SSN")) !,?10,"SSN: ",RTD("SSN") W:$D(RTD("DOD")) " Deceased: ",RTD("DOD")," " W ?42,"Date of Birth: ",RTD("DOB") K RTD
I $D(^RT(RT,"CL")) S I=^("CL"),RTPH=$S($D(^RTV(195.9,+$P(I,"^",5),0)):$P(^(0),"^",7),1:""),Y=+$P(I,"^",5) D BOR^RTB W !?5,"Location: ",$E(Y,1,22),?45,"Phone/Room: ",RTPH W:Y["MISSING" *7
D FND:$D(^RTV(190.2,"AM","s",RT)) K Y,RT,RTPH
RESTORE S RTZ="%" F RTZ1=0:0 S RTZ=$O(RTZ(RTZ)) Q:RTZ="" S @RTZ=RTZ(RTZ)
K RTZ,RTZ1 Q
;
SAVE K RTZ F RTZ2=1:1 S RTZ=$P(RTZ1,"^",RTZ2) Q:RTZ="" S:$D(@RTZ) RTZ(RTZ)=@RTZ
K RTZ1,RTZ2 Q
;
FND W !?5,"...record was missing but has been found pending supervisor approval" Q
;
DISP1 ;Executed by the ^DD(190.1,0,"ID","WRITE") node
S RTY1=Y W " REC#: ",+^RTV(190.1,+Y,0)," REQ#: ",Y," " S Y=+$P(^RTV(190.1,+Y,0),"^",5),RTD=+$P(^(0),"^",4) D BOR^RTB W !?4,"Requestor: ",Y
S Y=RTD D D^DIQ W ?44,"Date Needed: ",Y S Y=RTY1 K RTY1,RTD I $D(^RTV(190.1,+Y,0))
Q
;
DPA2 ;Entry point to display identifiers for request from NUM^RTDPA2
Q:'$D(^RTV(190.1,+Y,0)) S RTQ1=Y D DISP1 S Y=+^RTV(190.1,+Y,0) I $D(^RT(Y,0)) D DISP
S Y=RTQ1 K RTQ1 D LINE^RTUTL3 I ^RTV(190.1,+Y,0)
Q
;
OVER I '$D(^RT(D0,0))!('$D(^("CL")))!('$D(^DIC(195.2,+$P(^(0),U,3),0))) S X="" Q
;naked ref to the 0 node of type of record for a record entry
S RTT0=^(0),RT0=^RT(D0,0),RTCL=^("CL") D OVER1 K RT0,RTCL,RTT0 Q
;
OVER1 I $P(RT0,U,6)=$P(RTCL,U,5) S X="" Q
S X1=DT,X2=$P(RTCL,U,6) D ^%DTC S X=$S(X'<$P(RTT0,"^",11):X-$P(RTT0,"^",11),1:"") Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTUTL1 3775 printed Dec 13, 2024@02:35:06 Page 2
RTUTL1 ;MJK,PKE/ISC-ALBANY-Utility Routine; ; 4/24/87 9:22 AM ;
+1 ;;v 2.0;Record Tracking;;10/22/91
MOVE if '$DATA(^RT(RT,"CL"))
QUIT
SET RTM=^("CL")
SET X1=+RTM
SET $PIECE(RTM,"^",1,4)=RT_"^^^"
IF $DATA(^RTV(190.1,X1,0))
SET $PIECE(RTM,"^",2,4)=$PIECE(^(0),"^",2,4)
+1 SET I=+$PIECE(^RTV(190.3,0),"^",3)
LOC SET I1=I
SET I=$ORDER(^RTV(190.3,I))
IF I1+1=I
GOTO LOC
+1 LOCK +^RTV(190.3,I1+1):1
IF '$TEST!(I1=999)!($DATA(^(I1+1,0)))
LOCK -^RTV(190.3,I1+1)
SET I=I1+1
if $LENGTH(I)=4
SET I=9999
GOTO LOC
+2 SET I=I1+1
+3 SET ^RTV(190.3,I,0)=RT
SET ^RTV(190.3,"B",RT,I)=""
SET ^(0)=$PIECE(^RTV(190.3,0),"^",1,2)_"^"_I_"^"_($PIECE(^(0),"^",4)+1)
SET ^DISV($SELECT($DATA(DUZ)'[0:DUZ,1:0),"^RTV(190.3,")=I
LOCK -^RTV(190.3,I1+1)
+4 SET (DA,RTLAST)=I
SET DIE="^RTV(190.3,"
SET DR="[RT MOVEMENT]"
DO ^DIE
KILL DE,DQ,RTLAST,RTM,X,X1,I,I1
QUIT
+5 ;
ARRAY FOR I=0:0
SET I=$ORDER(RTY(I))
if 'I
QUIT
SET Y=+RTY(I)
DO ARRAY1
+1 KILL I
QUIT
ARRAY1 IF $DATA(RTDEL)
IF '$DATA(^TMP($JOB,"RT","XREF",+Y))
WRITE !?3,*7,"...not on list to be processed"
QUIT
+1 IF $DATA(RTDEL)
KILL ^TMP($JOB,"RT","AR",+^(+Y)),^TMP($JOB,"RT","XREF",+Y)
SET RTN=RTN-1
WRITE !?3,"...deleted from list to be "_$SELECT($DATA(Y("M")):Y("M"),1:"processed")
KILL Y
QUIT
+2 IF $DATA(^TMP($JOB,"RT","XREF",+Y))
WRITE !?3,*7,"...already selected"
KILL Y
QUIT
+3 SET RTN=RTN+1
SET ^TMP($JOB,"RT","AR",RTN)=Y
SET ^TMP($JOB,"RT","XREF",+Y)=RTN
WRITE !?3,"...added to list to be "_$SELECT($DATA(Y("M")):Y("M"),1:"processed")
QUIT
+4 ;
DEMOS if '$DATA(^RT(RT,0))
QUIT
SET Y=^(0)
SET RTD("V")=$PIECE(Y,"^",7)
SET RTD("T")=$SELECT($DATA(^DIC(195.2,+$PIECE(Y,"^",3),0)):$PIECE(^(0),"^"),1:"UNKNOWN")_" (V"_+$PIECE(Y,"^",7)_") "
SET RTD("A")=$SELECT($DATA(^(0)):$PIECE(^(0),"^",2),1:"UNK")
SET Y=$PIECE(Y,"^")
DEMOS1 SET N=Y
DO NAME^RTB
SET RTD("N")=Y
+1 IF $PIECE(N,";",2)="DPT("
IF $DATA(^DPT(+N,0))
SET Y=^(0)
SET Y1=$PIECE(Y,"^",9)
SET RTD("SSN")=$EXTRACT(Y1,1,3)_"-"_$EXTRACT(Y1,4,5)_"-"_$EXTRACT(Y1,6,10)
SET Y=$PIECE(Y,"^",3)
if Y
DO D^DIQ
SET RTD("DOB")=Y
if $DATA(^(.1))
SET RTD("W")=^(.1)
IF $DATA(^(.35))
SET Y=+$PIECE(^(.35),".")
IF Y
DO D^DIQ
SET RTD("DOD")=Y
DEMOS2 SET Y=""
IF $DATA(RT)
IF $DATA(^RT(+RT,"CL"))
SET Y=^("CL")
DEMOS3 SET Y2=Y
SET Y1=$SELECT($DATA(^RTV(195.9,+$PIECE(Y,"^",5),0)):^(0),1:"")
SET RTD("P")=$PIECE(Y1,"^",8)
SET RTD("L")=$PIECE(Y1,"^",9)
SET RTD("P1")=$PIECE(Y1,"^",7)
SET Y=+$EXTRACT($PIECE(Y,"^",6),1,12)
if Y
DO D^DIQ
SET RTD("D")=Y
SET Y=$PIECE(Y1,"^")
DO NAME^RTB
SET RTD("B")=Y
+1 IF $DATA(^RTV(195.9,+$PIECE(Y2,"^",14),0))
SET Y=^(0)
SET RTD("PROVP")=$PIECE(Y,"^",8)
SET RTD("PROVL")=$PIECE(Y,"^",9)
SET Y=$PIECE(Y,"^")
DO NAME^RTB
SET RTD("PROV")=Y
+2 KILL Y,Y1,Y2
QUIT
+3 ;
DISP ;Executed by the ^DD(190,0,"ID","WRITE") node
+1 SET RTZ1="Y^RT"
DO SAVE
SET RT=+Y
DO DEMOS
if $X>50
WRITE !
WRITE ?50," Type: ",$EXTRACT(RTD("T"),1,22)
if $DATA(RTD("SSN"))
WRITE !,?10,"SSN: ",RTD("SSN")
if $DATA(RTD("DOD"))
WRITE " Deceased: ",RTD("DOD")," "
WRITE ?42,"Date of Birth: ",RTD("DOB")
KILL RTD
+2 IF $DATA(^RT(RT,"CL"))
SET I=^("CL")
SET RTPH=$SELECT($DATA(^RTV(195.9,+$PIECE(I,"^",5),0)):$PIECE(^(0),"^",7),1:"")
SET Y=+$PIECE(I,"^",5)
DO BOR^RTB
WRITE !?5,"Location: ",$EXTRACT(Y,1,22),?45,"Phone/Room: ",RTPH
if Y["MISSING"
WRITE *7
+3 if $DATA(^RTV(190.2,"AM","s",RT))
DO FND
KILL Y,RT,RTPH
RESTORE SET RTZ="%"
FOR RTZ1=0:0
SET RTZ=$ORDER(RTZ(RTZ))
if RTZ=""
QUIT
SET @RTZ=RTZ(RTZ)
+1 KILL RTZ,RTZ1
QUIT
+2 ;
SAVE KILL RTZ
FOR RTZ2=1:1
SET RTZ=$PIECE(RTZ1,"^",RTZ2)
if RTZ=""
QUIT
if $DATA(@RTZ)
SET RTZ(RTZ)=@RTZ
+1 KILL RTZ1,RTZ2
QUIT
+2 ;
FND WRITE !?5,"...record was missing but has been found pending supervisor approval"
QUIT
+1 ;
DISP1 ;Executed by the ^DD(190.1,0,"ID","WRITE") node
+1 SET RTY1=Y
WRITE " REC#: ",+^RTV(190.1,+Y,0)," REQ#: ",Y," "
SET Y=+$PIECE(^RTV(190.1,+Y,0),"^",5)
SET RTD=+$PIECE(^(0),"^",4)
DO BOR^RTB
WRITE !?4,"Requestor: ",Y
+2 SET Y=RTD
DO D^DIQ
WRITE ?44,"Date Needed: ",Y
SET Y=RTY1
KILL RTY1,RTD
IF $DATA(^RTV(190.1,+Y,0))
+3 QUIT
+4 ;
DPA2 ;Entry point to display identifiers for request from NUM^RTDPA2
+1 if '$DATA(^RTV(190.1,+Y,0))
QUIT
SET RTQ1=Y
DO DISP1
SET Y=+^RTV(190.1,+Y,0)
IF $DATA(^RT(Y,0))
DO DISP
+2 SET Y=RTQ1
KILL RTQ1
DO LINE^RTUTL3
IF ^RTV(190.1,+Y,0)
+3 QUIT
+4 ;
OVER IF '$DATA(^RT(D0,0))!('$DATA(^("CL")))!('$DATA(^DIC(195.2,+$PIECE(^(0),U,3),0)))
SET X=""
QUIT
+1 ;naked ref to the 0 node of type of record for a record entry
+2 SET RTT0=^(0)
SET RT0=^RT(D0,0)
SET RTCL=^("CL")
DO OVER1
KILL RT0,RTCL,RTT0
QUIT
+3 ;
OVER1 IF $PIECE(RT0,U,6)=$PIECE(RTCL,U,5)
SET X=""
QUIT
+1 SET X1=DT
SET X2=$PIECE(RTCL,U,6)
DO ^%DTC
SET X=$SELECT(X'<$PIECE(RTT0,"^",11):X-$PIECE(RTT0,"^",11),1:"")
QUIT
