RTSYS ;TROY ISC/MJK-Record Tracking System Definition Menu ; 5/19/87 11:34 AM ; 4/10/03 3:27pm
;;2.0;Record Tracking;**21,29,35,37,40**;10/22/91
D DT^DICRW S X=$T(+1),DIK="^DOPT("""_$P(X," ;",1)_""","
G:$D(^DOPT($P(X," ;"),9)) A S ^DOPT($P(X," ;"),0)=$P(X,";",3)_"^1N^" F I=1:1 S Y=$T(@I) Q:Y="" S ^DOPT($P(X," ;"),I,0)=$P(Y,";",3,99)
D IXALL^DIK
A D OVERALL^RTPSET Q:$D(XQUIT)
W !! S DIC="^DOPT("""_$P($T(+1)," ;")_""",",DIC(0)="IQEAM" D ^DIC Q:Y<0 D @+Y G A
;
1 ;;Type of Record Set-up
W ! S DIC("DR")="3////"_+RTAPL,DIC("A")="Select Record Type: ",DIC(0)="IAEMLQ",DIC("S")="I $P(^(0),U,3)=+RTAPL",DIC="^DIC(195.2,",DLAYGO=195.2 D ^DIC K DIC,DLAYGO G Q:Y<0 S DA=+Y
S DIE="^DIC(195.2,",DR="[RT TYPE SET-UP]" D ^DIE K DQ,DE G 1
Q K DA,D0,DIC,DIE,DR,I,C,P,X,Y,RT0 Q
;
2 ;;File Room Set-up
L2 D FR^RTSM G Q:Y<0 S DA=+Y,DIE="^RTV(195.9,",DR="[RT FILE ROOM SET-UP]" D ^DIE K DQ,DE G L2
Q2 Q
;
3 ;;Application Set-up
W ! S DA=+RTAPL,DIE="^DIC(195.1,",DR="[RT APPL SET-UP]" D ^DIE K DE,DQ G Q
;
4 ;;Reasons File Set-up
L4 W ! S DIC("DR")="3////"_+RTAPL,DIC("A")="Select Reason: ",DIC(0)="IAEMLQ",DIC("S")="I $P(^(0),U,3)=+RTAPL",DIC="^DIC(195.6," D ^DIC K DIC G Q:Y<0 S DA=+Y
S DIE="^DIC(195.6,",DR="[RT REASON SET-UP]" D ^DIE K DQ,DE G L4
Q4 Q
;
5 ;;Label Function Menu
G ^RTL
;
6 ;;Individual Borrower Set-up
L6 W ! S A=+RTAPL D DIC^RTDPA31 S DIC="^RTV(195.9,",DIC("A")="Select Borrower: ",DIC(0)="IAELMQ",DIC("S")="S Z0=^(0),Z=$P($P(Z0,U),"";"",2) I $P(Z0,U,3)="_+RTAPL_" D DICS1^RTSYS" D ^DIC K DIC G Q6:Y<0
;
D BOR G L6
Q6 K RTDA G Q
;
BOR S DA=+Y,DR="[RT BORROWER SET-UP]",DIE="^RTV(195.9," D ^DIE K DE,DQ Q
;
7 ;;[FOR FUTURE USE]
;
TFR W ! S DIC(0)="IAEMQ",DIC="^DIC(4,",DIC("A")="Transfer Institution: " D ^DIC K DIC Q:Y<0 S RTA=+RTAPL,RTB=+Y_";DIC(4,",Y=+$O(^RTV(195.9,"ABOR",RTB,RTA,0)) D SET^RTDPA3:'Y K RTB,RTA
Q
;
8 ;;Print Borrower Label
I $S('$D(^DIC(194.4,+$P(RTAPL,"^",3),0)):1,$P(^(0),"^",4)'="b":1,$P(^(0),"^",3)'=+RTAPL:1,1:0) W !?3,*7,"No valid borrower label format assigned for application." G Q8
S DIC("A")="Select Borrower: ",DIC="^RTV(195.9,",DIC(0)="IAEMLQ",DIC("DR")="3////"_+RTAPL,DIC("S")="I $P(^(0),U,3)="_+RTAPL D ^DIC K DIC G Q8:Y<0
S:$D(RTFR) RTION=$P(RTFR,"^",4) S RTIFN=+Y,RTFMT=+$P(RTAPL,"^",3),RTMES="W !?3,""...Barcode label has been queued to print on device "",RTION,"".""",RTNUM=1 D Q^RTL1 G 8
Q8 K RTFMT,RTA,RTIFN,RTION,RTNUM,RTMES G Q
;
9 ;;Add/Edit 'PERSON' Borrower
;W ! S DIC="^VA(200,",DIC(0)="IAEQELM" D ^DIC K DIC G Q:Y<0 D CHK^RTDPA3,BOR:Y>0 G 9
Q9 Q
;
OTHER ;
W !!,"Applications Using this 'PERSON' borrower:" S I=0 F A=0:0 S A=$O(^RTV(195.9,"ABOR",$P(Y,"^",2),A)) Q:'A S I=I+1 W !?5,"- ",$S($D(^DIC(195.1,A,0)):$P(^(0),"^"),1:"UNKNOWN")
W:'I !!?5,*7,"No applications use this 'PERSON'." W !!,"Be careful when changing the 'NAME' of this 'PERSON' borrower." K A,I Q
;
10 ;;Movement Type Set-up
W ! S DIC="^DIC(195.3,",DIC(0)="IAEMQ",DIC("S")="I $P(^(0),U,3)="_+RTAPL,DIC("A")="Select MOVEMENT TYPE: " D ^DIC K DIC G Q:Y<0 S DA=+Y,DIE="^DIC(195.3,",DR="[RT MOVEMENT SET-UP]" D ^DIE K DE,DR,DQ G 10
Q
;
DICS1 ; DICS1^RTDPA31 is called by multiple routines
; copied from RTDPA31 isolate changes needed for patch RT*2*37
I '$D(^DIC(195.1,+$P(Z0,"^",3),"BOR","AC",Z)) X "I 0" G DICSQ
I Z="DIC(4,",$S('$D(^DIC(195.1,+$P(Z0,U,3),0)):1,$P(^(0),U,8)']"":1,1:'$D(^XUSEC($P(^(0),U,8),DUZ))) X "I 0" G DICSQ
I "SC(;DIC(42,"'[Z G DICSQ
;inactive flags check
;
I Z="SC(" S Z1=$S('$D(^SC(+Z0,"I")):1,'^("I"):1,DT<+^("I"):1,'$P(^("I"),"^",2):0,+$P(^("I"),"^",2):1,1:0) X "I Z1" G DICSQ
I Z="DIC(42," N D0,X S D0=+Z0 D WIN^DGPMDDCF X "I 'X" G DICSQ
;
DICSQ K Z,Z0,Z1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTSYS 3723 printed Oct 16, 2024@18:35:37 Page 2
RTSYS ;TROY ISC/MJK-Record Tracking System Definition Menu ; 5/19/87 11:34 AM ; 4/10/03 3:27pm
+1 ;;2.0;Record Tracking;**21,29,35,37,40**;10/22/91
+2 DO DT^DICRW
SET X=$TEXT(+1)
SET DIK="^DOPT("""_$PIECE(X," ;",1)_""","
+3 if $DATA(^DOPT($PIECE(X," ;"),9))
GOTO A
SET ^DOPT($PIECE(X," ;"),0)=$PIECE(X,";",3)_"^1N^"
FOR I=1:1
SET Y=$TEXT(@I)
if Y=""
QUIT
SET ^DOPT($PIECE(X," ;"),I,0)=$PIECE(Y,";",3,99)
+4 DO IXALL^DIK
A DO OVERALL^RTPSET
if $DATA(XQUIT)
QUIT
+1 WRITE !!
SET DIC="^DOPT("""_$PIECE($TEXT(+1)," ;")_""","
SET DIC(0)="IQEAM"
DO ^DIC
if Y<0
QUIT
DO @+Y
GOTO A
+2 ;
1 ;;Type of Record Set-up
+1 WRITE !
SET DIC("DR")="3////"_+RTAPL
SET DIC("A")="Select Record Type: "
SET DIC(0)="IAEMLQ"
SET DIC("S")="I $P(^(0),U,3)=+RTAPL"
SET DIC="^DIC(195.2,"
SET DLAYGO=195.2
DO ^DIC
KILL DIC,DLAYGO
if Y<0
GOTO Q
SET DA=+Y
+2 SET DIE="^DIC(195.2,"
SET DR="[RT TYPE SET-UP]"
DO ^DIE
KILL DQ,DE
GOTO 1
Q KILL DA,D0,DIC,DIE,DR,I,C,P,X,Y,RT0
QUIT
+1 ;
2 ;;File Room Set-up
L2 DO FR^RTSM
if Y<0
GOTO Q
SET DA=+Y
SET DIE="^RTV(195.9,"
SET DR="[RT FILE ROOM SET-UP]"
DO ^DIE
KILL DQ,DE
GOTO L2
Q2 QUIT
+1 ;
3 ;;Application Set-up
+1 WRITE !
SET DA=+RTAPL
SET DIE="^DIC(195.1,"
SET DR="[RT APPL SET-UP]"
DO ^DIE
KILL DE,DQ
GOTO Q
+2 ;
4 ;;Reasons File Set-up
L4 WRITE !
SET DIC("DR")="3////"_+RTAPL
SET DIC("A")="Select Reason: "
SET DIC(0)="IAEMLQ"
SET DIC("S")="I $P(^(0),U,3)=+RTAPL"
SET DIC="^DIC(195.6,"
DO ^DIC
KILL DIC
if Y<0
GOTO Q
SET DA=+Y
+1 SET DIE="^DIC(195.6,"
SET DR="[RT REASON SET-UP]"
DO ^DIE
KILL DQ,DE
GOTO L4
Q4 QUIT
+1 ;
5 ;;Label Function Menu
+1 GOTO ^RTL
+2 ;
6 ;;Individual Borrower Set-up
L6 WRITE !
SET A=+RTAPL
DO DIC^RTDPA31
SET DIC="^RTV(195.9,"
SET DIC("A")="Select Borrower: "
SET DIC(0)="IAELMQ"
SET DIC("S")="S Z0=^(0),Z=$P($P(Z0,U),"";"",2) I $P(Z0,U,3)="_+RTAPL_" D DICS1^RTSYS"
DO ^DIC
KILL DIC
if Y<0
GOTO Q6
+1 ;
+2 DO BOR
GOTO L6
Q6 KILL RTDA
GOTO Q
+1 ;
BOR SET DA=+Y
SET DR="[RT BORROWER SET-UP]"
SET DIE="^RTV(195.9,"
DO ^DIE
KILL DE,DQ
QUIT
+1 ;
7 ;;[FOR FUTURE USE]
+1 ;
TFR WRITE !
SET DIC(0)="IAEMQ"
SET DIC="^DIC(4,"
SET DIC("A")="Transfer Institution: "
DO ^DIC
KILL DIC
if Y<0
QUIT
SET RTA=+RTAPL
SET RTB=+Y_";DIC(4,"
SET Y=+$ORDER(^RTV(195.9,"ABOR",RTB,RTA,0))
if 'Y
DO SET^RTDPA3
KILL RTB,RTA
+1 QUIT
+2 ;
8 ;;Print Borrower Label
+1 IF $SELECT('$DATA(^DIC(194.4,+$PIECE(RTAPL,"^",3),0)):1,$PIECE(^(0),"^",4)'="b":1,$PIECE(^(0),"^",3)'=+RTAPL:1,1:0)
WRITE !?3,*7,"No valid borrower label format assigned for application."
GOTO Q8
+2 SET DIC("A")="Select Borrower: "
SET DIC="^RTV(195.9,"
SET DIC(0)="IAEMLQ"
SET DIC("DR")="3////"_+RTAPL
SET DIC("S")="I $P(^(0),U,3)="_+RTAPL
DO ^DIC
KILL DIC
if Y<0
GOTO Q8
+3 if $DATA(RTFR)
SET RTION=$PIECE(RTFR,"^",4)
SET RTIFN=+Y
SET RTFMT=+$PIECE(RTAPL,"^",3)
SET RTMES="W !?3,""...Barcode label has been queued to print on device "",RTION,""."""
SET RTNUM=1
DO Q^RTL1
GOTO 8
Q8 KILL RTFMT,RTA,RTIFN,RTION,RTNUM,RTMES
GOTO Q
+1 ;
9 ;;Add/Edit 'PERSON' Borrower
+1 ;W ! S DIC="^VA(200,",DIC(0)="IAEQELM" D ^DIC K DIC G Q:Y<0 D CHK^RTDPA3,BOR:Y>0 G 9
Q9 QUIT
+1 ;
OTHER ;
+1 WRITE !!,"Applications Using this 'PERSON' borrower:"
SET I=0
FOR A=0:0
SET A=$ORDER(^RTV(195.9,"ABOR",$PIECE(Y,"^",2),A))
if 'A
QUIT
SET I=I+1
WRITE !?5,"- ",$SELECT($DATA(^DIC(195.1,A,0)):$PIECE(^(0),"^"),1:"UNKNOWN")
+2 if 'I
WRITE !!?5,*7,"No applications use this 'PERSON'."
WRITE !!,"Be careful when changing the 'NAME' of this 'PERSON' borrower."
KILL A,I
QUIT
+3 ;
10 ;;Movement Type Set-up
+1 WRITE !
SET DIC="^DIC(195.3,"
SET DIC(0)="IAEMQ"
SET DIC("S")="I $P(^(0),U,3)="_+RTAPL
SET DIC("A")="Select MOVEMENT TYPE: "
DO ^DIC
KILL DIC
if Y<0
GOTO Q
SET DA=+Y
SET DIE="^DIC(195.3,"
SET DR="[RT MOVEMENT SET-UP]"
DO ^DIE
KILL DE,DR,DQ
GOTO 10
+2 QUIT
+3 ;
DICS1 ; DICS1^RTDPA31 is called by multiple routines
+1 ; copied from RTDPA31 isolate changes needed for patch RT*2*37
+2 IF '$DATA(^DIC(195.1,+$PIECE(Z0,"^",3),"BOR","AC",Z))
XECUTE "I 0"
GOTO DICSQ
+3 IF Z="DIC(4,"
IF $SELECT('$DATA(^DIC(195.1,+$PIECE(Z0,U,3),0)):1,$PIECE(^(0),U,8)']"":1,1:'$DATA(^XUSEC($PIECE(^(0),U,8),DUZ)))
XECUTE "I 0"
GOTO DICSQ
+4 IF "SC(;DIC(42,"'[Z
GOTO DICSQ
+5 ;inactive flags check
+6 ;
+7 IF Z="SC("
SET Z1=$SELECT('$DATA(^SC(+Z0,"I")):1,'^("I"):1,DT<+^("I"):1,'$PIECE(^("I"),"^",2):0,+$PIECE(^("I"),"^",2):1,1:0)
XECUTE "I Z1"
GOTO DICSQ
+8 IF Z="DIC(42,"
NEW D0,X
SET D0=+Z0
DO WIN^DGPMDDCF
XECUTE "I 'X"
GOTO DICSQ
+9 ;
DICSQ KILL Z,Z0,Z1
QUIT
