- RTTR ;ISC-ALBANY/PKE;Record Transfer Option ; ; 9/10/90 14:24 ;
- ;;v 2.0;Record Tracking;;10/22/91
- D DT^DICRW S X=$T(+1),DIK="^DOPT("""_$P(X," ;",1)_"""," G:$D(^DOPT($P(X," ;"),10)) 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)="IQEAMZ" D ^DIC Q:Y<0 D @+Y G A
- ;
- 1 ;;Transfer a Record to another Institution
- ; include reply
- W ! K RTB,RTJST S X="TRANSFER TO" D LK I RTINACFL D TFR^RTSYS I Y>0 S RTKEY=1,RTB=+Y D DR^RTDPA3,CO^RTT I $D(RTPAST),RTPAST'<DT,'$D(RTJST) D A^RTTR2
- Q K RTKEY,RTFIN,RTINACFL,RTB,RTPAST,RTJST
- K ^TMP($J,"RT"),RTAR,RTV,J,DA,DIE,DIC,DR Q
- ;
- 2 ;;Return transferred Record from another Institution
- W ! K RTB S X="TRANSFER BACK" D LK I 'RTINACFL D CI^RTT
- G Q
- ;
- 3 ;;Create Record/volume from another Institution
- G TRAN^RTDPA1
- ;
- 4 ;;Request Transfer from another Institution
- G 4^RTTR1
- Q
- LK S DIC="^DIC(195.3,",DIC(0)="IEMQEZ",DIC("S")="I $P(^(0),U,3)=+RTAPL" D ^DIC K DIC Q:Y<0 S RTMV=+Y,RTMV0=Y(0),RTINACFL=$P(Y(0),"^")["TRANSFER TO"
- Q
- DAT ;to allow backdating of record transfers to institutions
- ;RTPAST used in rt charge template
- S DIR(0)="D^:NOW:AETX",DIR("A")="Enter the date of Transfer",DIR("B")="NOW" D ^DIR K DIR Q:$D(DUOUT)!($D(DTOUT)) S RTPAST=Y Q
- ;
- INST S A=+RTAPL D DIC^RTDPA31 S DIC="^RTV(195.9,",DIC("A")="Select Institution: "
- S DIC(0)="IAEMQ",DIC("S")="S Z0=^(0),Z=$P($P(Z0,U),"";"",2) I Z=""DIC(4,"",$P(Z0,U,3)="_+RTAPL_" D DICS1^RTDPA31"
- Q
- SM ;site manager instituition/borrower setup
- D DIP W !!,"Remote Institution Parameters:",!,"-----------------------------"
- RE D INST,^DIC I Y'<0 S DA=+Y,DIE="^RTV(195.9,",DR="[RT FILE ROOM/REMOTE]" D ^DIE K DQ,DE G RE
- K RTREMOTE,DIC,DA,D0,DR,DIE Q
- Q
- DIP W !!?5,"...compiling Remote/Institution profile for ",$P($P(RTAPL,"^",1),";",2),!
- S DIC="^RTV(195.9,",(BY,FLDS)="[RT FILE ROOM/REMOTE]",L=0,(FR,TO)="",DIS(0)="I $P(^RTV(195.9,D0,0),U,3)=+RTAPL" K DTOUT D EN1^DIP K DIC,FLDS,BY,L,TO,FR,IOP Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTTR 2091 printed Jan 18, 2025@03:36:11 Page 2
- RTTR ;ISC-ALBANY/PKE;Record Transfer Option ; ; 9/10/90 14:24 ;
- +1 ;;v 2.0;Record Tracking;;10/22/91
- +2 DO DT^DICRW
- SET X=$TEXT(+1)
- SET DIK="^DOPT("""_$PIECE(X," ;",1)_""","
- if $DATA(^DOPT($PIECE(X," ;"),10))
- 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)
- +3 DO IXALL^DIK
- A DO OVERALL^RTPSET
- if $DATA(XQUIT)
- QUIT
- WRITE !!
- SET DIC="^DOPT("""_$PIECE($TEXT(+1)," ;")_""","
- SET DIC(0)="IQEAMZ"
- DO ^DIC
- if Y<0
- QUIT
- DO @+Y
- GOTO A
- +1 ;
- 1 ;;Transfer a Record to another Institution
- +1 ; include reply
- +2 WRITE !
- KILL RTB,RTJST
- SET X="TRANSFER TO"
- DO LK
- IF RTINACFL
- DO TFR^RTSYS
- IF Y>0
- SET RTKEY=1
- SET RTB=+Y
- DO DR^RTDPA3
- DO CO^RTT
- IF $DATA(RTPAST)
- IF RTPAST'<DT
- IF '$DATA(RTJST)
- DO A^RTTR2
- Q KILL RTKEY,RTFIN,RTINACFL,RTB,RTPAST,RTJST
- +1 KILL ^TMP($JOB,"RT"),RTAR,RTV,J,DA,DIE,DIC,DR
- QUIT
- +2 ;
- 2 ;;Return transferred Record from another Institution
- +1 WRITE !
- KILL RTB
- SET X="TRANSFER BACK"
- DO LK
- IF 'RTINACFL
- DO CI^RTT
- +2 GOTO Q
- +3 ;
- 3 ;;Create Record/volume from another Institution
- +1 GOTO TRAN^RTDPA1
- +2 ;
- 4 ;;Request Transfer from another Institution
- +1 GOTO 4^RTTR1
- +2 QUIT
- LK SET DIC="^DIC(195.3,"
- SET DIC(0)="IEMQEZ"
- SET DIC("S")="I $P(^(0),U,3)=+RTAPL"
- DO ^DIC
- KILL DIC
- if Y<0
- QUIT
- SET RTMV=+Y
- SET RTMV0=Y(0)
- SET RTINACFL=$PIECE(Y(0),"^")["TRANSFER TO"
- +1 QUIT
- DAT ;to allow backdating of record transfers to institutions
- +1 ;RTPAST used in rt charge template
- +2 SET DIR(0)="D^:NOW:AETX"
- SET DIR("A")="Enter the date of Transfer"
- SET DIR("B")="NOW"
- DO ^DIR
- KILL DIR
- if $DATA(DUOUT)!($DATA(DTOUT))
- QUIT
- SET RTPAST=Y
- QUIT
- +3 ;
- INST SET A=+RTAPL
- DO DIC^RTDPA31
- SET DIC="^RTV(195.9,"
- SET DIC("A")="Select Institution: "
- +1 SET DIC(0)="IAEMQ"
- SET DIC("S")="S Z0=^(0),Z=$P($P(Z0,U),"";"",2) I Z=""DIC(4,"",$P(Z0,U,3)="_+RTAPL_" D DICS1^RTDPA31"
- +2 QUIT
- SM ;site manager instituition/borrower setup
- +1 DO DIP
- WRITE !!,"Remote Institution Parameters:",!,"-----------------------------"
- RE DO INST
- DO ^DIC
- IF Y'<0
- SET DA=+Y
- SET DIE="^RTV(195.9,"
- SET DR="[RT FILE ROOM/REMOTE]"
- DO ^DIE
- KILL DQ,DE
- GOTO RE
- +1 KILL RTREMOTE,DIC,DA,D0,DR,DIE
- QUIT
- +2 QUIT
- DIP WRITE !!?5,"...compiling Remote/Institution profile for ",$PIECE($PIECE(RTAPL,"^",1),";",2),!
- +1 SET DIC="^RTV(195.9,"
- SET (BY,FLDS)="[RT FILE ROOM/REMOTE]"
- SET L=0
- SET (FR,TO)=""
- SET DIS(0)="I $P(^RTV(195.9,D0,0),U,3)=+RTAPL"
- KILL DTOUT
- DO EN1^DIP
- KILL DIC,FLDS,BY,L,TO,FR,IOP
- QUIT