- 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 Jan 18, 2025@03:36:02 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