- 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 Mar 13, 2025@21:40:12 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
