RTNQ4 ;MJK,PKE/TROY ISC;Expanded Record Inquiry Routine ; 5/4/87 9:57 AM ;
;;2.0;Record Tracking;**32,36**;10/22/91
I '$D(RTAPL) D APL2^RTPSET D NEXT:$D(RTAPL) K RTAPL,RTSYS Q
NEXT S RTA=+RTAPL D ASK^RTB K RTA G Q:$D(RTESC),NEXT:Y<0 S RTE=X
S RTINFO="A"
S RTPGM="START^RTNQ4",RTVAR="RTE^RTINFO^RTAPL" D ZIS^RTUTL G Q:POP D START G NEXT
;
START U IO S RTPAGE=0,RTFL="RECS",RTUTL=0
K RT,^TMP($J,"RTNQ"),R2,R3,Z
I '$D(IOSL)!('$D(IOF)) S IOP="" D ^%ZIS K IOP
D TYPE,HD
I RTINFO["A" S A=+RTAPL F RT=0:0 S RT=$O(^RT("AA",A,RTE,RT)) Q:'RT S RT(RT)=""
G Q:$D(RT)<10 K RTL F RT=0:0 S RT=$O(RT(RT)) Q:'RT K RT(RT) I $D(^RT(RT,0)) S RT0=^(0) I $D(RTO(+$P(RT0,"^",3))) S RT(RT)=RT0 D REC
D ^RTNQ41
S C=0,RTESC="" K R F O=0:0 S O=$O(RTL(O)) Q:'O F V=0:0 S V=$O(RTL(O,V)) Q:'V S C=C+1,R(C)=^TMP($J,"RTNQ",RTL(O,V),1) D WRITE:C=3 G Q:RTESC="^"
; c is number of volumes
D WRITE:C
Q
Q K C,S,RTVAR,RTPGM,RTQ,RTWND,RTDT,R,RT,RT0,RTA,RTE,RTESC,RTFL,RTINFO,RTL,RTO,RTPAGE,RTUTL,^TMP($J,"RTNQ"),R2,R3,Z D CLOSE^RTUTL
K DIC,DIY,N,A,F,O,X1,%I,%H,POP,X
K:'$D(RTY) RTINFO K RT1,RTC,RTY,RTDC,RTSEL
K M,T,DFN,CT,I,T,V,VADMVT,Y Q
;
HD S RTESC="" I RTPAGE,IOST["C-" W !! R !,"Press RETURN to continue or '^' to stop: ",RTESC:DTIME S:'$T RTESC="^" Q:RTESC["^"
S RTPAGE=RTPAGE+1,X1=$S($D(^DIC(195.1,+RTAPL,"HD")):^("HD"),1:"Record")_" Inquiry" D PTHD^RTUTL2,EQUALS^RTUTL3
Q
;
REC S Y=RT0 Q:'$D(^RT(RT,"CL")) S RTCL=^("CL"),R("BC")=$S($P(RTCL,"^",15)="y":"Barcode",1:"Non-barcode"),T=+$P(Y,"^",3),V=+$P(Y,"^",7),R("DES")=$P(Y,"^",12),Y=$P(Y,"^",11),C=$P(^DD(190,11,0),"^",2) D Y^DIQ S R("R")=Y
S (H,H("P"))="" I $D(^RTV(195.9,+$P(RT0,"^",6),0)) S Y=^(0),H("P")=$P(Y,"^",7),Y=$P(Y,"^") D NAME^RTB S H=Y
;
S Y=RTCL,D=$P(Y,"^",6)_".00000",D=$TR($$FMTE^XLFDT($E(D,1,12),"5F")," /","0-")
S U1=$S($D(^VA(200,+$P(Y,"^",7),0)):$P(^(0),"^"),1:"UNKNOWN")
S Y=$P(Y,"^",8),C=$P(^DD(190,108,0),"^",2) D Y^DIQ S M=Y
S R("I")="" I $D(^RT(RT,"I")),^("I"),DT>^("I") S R("I")=$S(M["TRANSFER TO":"** Transferred **",1:"*** Inactive ***")
;
S (B,B("P"))="" I $D(^RTV(195.9,+$P(RTCL,"^",5),0)) S Y=^(0),B("P")=$P(Y,"^",7),Y=$P(Y,"^") D NAME^RTB S B=Y
S Y=$P(RTCL,"^",14) D BOR^RTB:Y S R("PROV")=Y
S RTUTL=RTUTL+1,RTL(+RTO(T),999-V)=RTUTL,^TMP($J,"RTNQ",RTUTL,1)=$P(RTO(T),"^",2)_"^"_V_"^"_RT_"^"_R("DES")_"^"_B_"^"_B("P")_"^"_R("PROV")_"^"_D_"^"_M_"^"_U1
RECQ K V,B,RTCL,D,H,R,M,U1,C,Y Q
;
WRITE S RTN=10 D HD:($Y+RTN+8)>9999 G WRITEQ:RTESC="^" F F=1:1:RTN W !,$P($T(LABELS+F),";;",2) F I=1:1 Q:'$D(R(I)) W ?(20+(20*(I-1))),$E($P(R(I),"^",F),1,19)
D DPL^RTNQ41
I C=3,$O(RTL(O))!($O(RTL(O,V))) D HD
WRITEQ K R,RTN S C=0 Q
;
TYPE F T=0:0 S T=$O(^DIC(195.2,"C",+RTAPL,T)) Q:'T I $D(^DIC(195.2,T,0)) S O=$S($P(^(0),"^",4)]"":+$P(^(0),"^",4),1:0),RTO(T)=$S(O:O,1:0)_"^"_$P(^(0),"^",1,2)
Q
LABELS ;;
;;Type of Record :
;;Volume No. :
;;Record No. :
;;Descriptor :
;;Current Location:
;;Current Phone :
;;Associated Borr.:
;;Since... :
;;Movement :
;;Responsible User:
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTNQ4 3058 printed Dec 13, 2024@02:34:08 Page 2
RTNQ4 ;MJK,PKE/TROY ISC;Expanded Record Inquiry Routine ; 5/4/87 9:57 AM ;
+1 ;;2.0;Record Tracking;**32,36**;10/22/91
+2 IF '$DATA(RTAPL)
DO APL2^RTPSET
if $DATA(RTAPL)
DO NEXT
KILL RTAPL,RTSYS
QUIT
NEXT SET RTA=+RTAPL
DO ASK^RTB
KILL RTA
if $DATA(RTESC)
GOTO Q
if Y<0
GOTO NEXT
SET RTE=X
+1 SET RTINFO="A"
+2 SET RTPGM="START^RTNQ4"
SET RTVAR="RTE^RTINFO^RTAPL"
DO ZIS^RTUTL
if POP
GOTO Q
DO START
GOTO NEXT
+3 ;
START USE IO
SET RTPAGE=0
SET RTFL="RECS"
SET RTUTL=0
+1 KILL RT,^TMP($JOB,"RTNQ"),R2,R3,Z
+2 IF '$DATA(IOSL)!('$DATA(IOF))
SET IOP=""
DO ^%ZIS
KILL IOP
+3 DO TYPE
DO HD
+4 IF RTINFO["A"
SET A=+RTAPL
FOR RT=0:0
SET RT=$ORDER(^RT("AA",A,RTE,RT))
if 'RT
QUIT
SET RT(RT)=""
+5 if $DATA(RT)<10
GOTO Q
KILL RTL
FOR RT=0:0
SET RT=$ORDER(RT(RT))
if 'RT
QUIT
KILL RT(RT)
IF $DATA(^RT(RT,0))
SET RT0=^(0)
IF $DATA(RTO(+$PIECE(RT0,"^",3)))
SET RT(RT)=RT0
DO REC
+6 DO ^RTNQ41
+7 SET C=0
SET RTESC=""
KILL R
FOR O=0:0
SET O=$ORDER(RTL(O))
if 'O
QUIT
FOR V=0:0
SET V=$ORDER(RTL(O,V))
if 'V
QUIT
SET C=C+1
SET R(C)=^TMP($JOB,"RTNQ",RTL(O,V),1)
if C=3
DO WRITE
if RTESC="^"
GOTO Q
+8 ; c is number of volumes
+9 if C
DO WRITE
+10 QUIT
Q KILL C,S,RTVAR,RTPGM,RTQ,RTWND,RTDT,R,RT,RT0,RTA,RTE,RTESC,RTFL,RTINFO,RTL,RTO,RTPAGE,RTUTL,^TMP($JOB,"RTNQ"),R2,R3,Z
DO CLOSE^RTUTL
+1 KILL DIC,DIY,N,A,F,O,X1,%I,%H,POP,X
+2 if '$DATA(RTY)
KILL RTINFO
KILL RT1,RTC,RTY,RTDC,RTSEL
+3 KILL M,T,DFN,CT,I,T,V,VADMVT,Y
QUIT
+4 ;
HD SET RTESC=""
IF RTPAGE
IF IOST["C-"
WRITE !!
READ !,"Press RETURN to continue or '^' to stop: ",RTESC:DTIME
if '$TEST
SET RTESC="^"
if RTESC["^"
QUIT
+1 SET RTPAGE=RTPAGE+1
SET X1=$SELECT($DATA(^DIC(195.1,+RTAPL,"HD")):^("HD"),1:"Record")_" Inquiry"
DO PTHD^RTUTL2
DO EQUALS^RTUTL3
+2 QUIT
+3 ;
REC SET Y=RT0
if '$DATA(^RT(RT,"CL"))
QUIT
SET RTCL=^("CL")
SET R("BC")=$SELECT($PIECE(RTCL,"^",15)="y":"Barcode",1:"Non-barcode")
SET T=+$PIECE(Y,"^",3)
SET V=+$PIECE(Y,"^",7)
SET R("DES")=$PIECE(Y,"^",12)
SET Y=$PIECE(Y,"^",11)
SET C=$PIECE(^DD(190,11,0),"^",2)
DO Y^DIQ
SET R("R")=Y
+1 SET (H,H("P"))=""
IF $DATA(^RTV(195.9,+$PIECE(RT0,"^",6),0))
SET Y=^(0)
SET H("P")=$PIECE(Y,"^",7)
SET Y=$PIECE(Y,"^")
DO NAME^RTB
SET H=Y
+2 ;
+3 SET Y=RTCL
SET D=$PIECE(Y,"^",6)_".00000"
SET D=$TRANSLATE($$FMTE^XLFDT($EXTRACT(D,1,12),"5F")," /","0-")
+4 SET U1=$SELECT($DATA(^VA(200,+$PIECE(Y,"^",7),0)):$PIECE(^(0),"^"),1:"UNKNOWN")
+5 SET Y=$PIECE(Y,"^",8)
SET C=$PIECE(^DD(190,108,0),"^",2)
DO Y^DIQ
SET M=Y
+6 SET R("I")=""
IF $DATA(^RT(RT,"I"))
IF ^("I")
IF DT>^("I")
SET R("I")=$SELECT(M["TRANSFER TO":"** Transferred **",1:"*** Inactive ***")
+7 ;
+8 SET (B,B("P"))=""
IF $DATA(^RTV(195.9,+$PIECE(RTCL,"^",5),0))
SET Y=^(0)
SET B("P")=$PIECE(Y,"^",7)
SET Y=$PIECE(Y,"^")
DO NAME^RTB
SET B=Y
+9 SET Y=$PIECE(RTCL,"^",14)
if Y
DO BOR^RTB
SET R("PROV")=Y
+10 SET RTUTL=RTUTL+1
SET RTL(+RTO(T),999-V)=RTUTL
SET ^TMP($JOB,"RTNQ",RTUTL,1)=$PIECE(RTO(T),"^",2)_"^"_V_"^"_RT_"^"_R("DES")_"^"_B_"^"_B("P")_"^"_R("PROV")_"^"_D_"^"_M_"^"_U1
RECQ KILL V,B,RTCL,D,H,R,M,U1,C,Y
QUIT
+1 ;
WRITE SET RTN=10
if ($Y+RTN+8)>9999
DO HD
if RTESC="^"
GOTO WRITEQ
FOR F=1:1:RTN
WRITE !,$PIECE($TEXT(LABELS+F),";;",2)
FOR I=1:1
if '$DATA(R(I))
QUIT
WRITE ?(20+(20*(I-1))),$EXTRACT($PIECE(R(I),"^",F),1,19)
+1 DO DPL^RTNQ41
+2 IF C=3
IF $ORDER(RTL(O))!($ORDER(RTL(O,V)))
DO HD
WRITEQ KILL R,RTN
SET C=0
QUIT
+1 ;
TYPE FOR T=0:0
SET T=$ORDER(^DIC(195.2,"C",+RTAPL,T))
if 'T
QUIT
IF $DATA(^DIC(195.2,T,0))
SET O=$SELECT($PIECE(^(0),"^",4)]"":+$PIECE(^(0),"^",4),1:0)
SET RTO(T)=$SELECT(O:O,1:0)_"^"_$PIECE(^(0),"^",1,2)
+1 QUIT
LABELS ;;
+1 ;;Type of Record :
+2 ;;Volume No. :
+3 ;;Record No. :
+4 ;;Descriptor :
+5 ;;Current Location:
+6 ;;Current Phone :
+7 ;;Associated Borr.:
+8 ;;Since... :
+9 ;;Movement :
+10 ;;Responsible User:
+11 ;
