RTT ;MJK/TROY ISC;Record Transaction Option; ; 5/19/87 9:58 AM ;
;;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)="IQEAM" D ^DIC Q:Y<0 D @+Y G A
;
1 ;;Create a Label/Record/Volume
G ^RTDPA1
;
2 ;;Delete a Record
G ^RTDEL
;
3 ;;Charge-Out Records
K RTB S X="CHARGE-OUT" D TYPE G Q:'$D(RTMV) D CO G 3:'$D(RTFIN) K RTFIN G Q
;
CO I '$D(RTDIV) D DIV1^RTPSET I '$D(RTDIV) D MES^RTP4 S RTFIN="" G Q
I RTMV0["TRANSFER TO" D DAT^RTTR G Q:'$D(RTPAST)
I RTMV0'["CHECK-IN" D PND^RTRPT IF 1
E D CPND^RTRPT
K RTFIN I $S('$D(RTB):1,'$D(^RTV(195.9,+RTB,0)):1,1:0) W ! K RTB D BOR^RTDPA32 I '$D(RTB) S RTFIN="" G Q
S:'$D(RTPROVFL) RTPROVFL=0 S RTN=0 K ^TMP($J,"RT") D SEL^RTT3
Q K RTC,X1,RTESC,%DT,POP,RTA,I1,RTWND,RTMV,RTMV0,RTN,RTESC,RTPROVFL,Z0
I '$D(RTKEY) K ^TMP($J,"RT"),RTPAST,RTB
K SSN,N,X,Y,JL,RTAR,Y,I,DIE,DA,DR,RTJST,DR,P
Q
;
4 ;;Re-charge a Record
RC K RTB S X="RE-CHARGE" D TYPE G Q:'$D(RTMV) D CO G 4:'$D(RTFIN) K RTFIN G Q
;
5 ;;Check-In Records
S X="CHECK-IN" D TYPE G Q:'$D(RTMV)
CI S Y=$S($D(RTFR):+RTFR,1:"")
I 'Y S DIC(0)="IAMEQ",DIC="^RTV(195.9,",DIC("A")="Select Check-In File Room: ",DIC("S")="I $P(^(0),U,3)=+RTAPL,$P(^(0),U,13)=""F"" D DICS^RTDPA31",DIC("V")="I $P(Y(0),U,4)=""L""" D ^DIC K DIC Q:Y<0
S RTB=+Y D CO K RTFIN Q
;
6 ;;Transfer Menu
G ^RTTR
;
7 ;;Flag Record as Missing
G 7^RTT1
;
8 ;;Record Charge-out to Patient
G 8^RTT4
;
9 ;;Update Record's Attributes
UP S RTSEL="S",DIC(0)="IAEMQ" D ^RTDPA K RTBCIFN,RTSEL G Q:'$D(RTY) S RTDR="13//NO;6;11//OK TO RETIRE^Update Record's Attributes: " D DR K RTDR G UP
;
10 ;;Inactivate/Re-activate Records
W ! S DIC="^DIC(195.3,",DIC(0)="IAEMQZ",DIC("A")="Select Movement Type: ",DIC("S")="I $P(^(0),U,3)=+RTAPL,$P(^(0),U)[""ACTIVATE""" D ^DIC K DIC G Q:Y<0 S RTMV=+Y,RTMV0=Y(0),RTINACFL=$P(Y(0),"^")["INACTIVATE"
K RTB D CO:RTINACFL,CI:'RTINACFL K RTFIN,RTINACFL,RTB G Q
;
11 ;;Multiple volume creation
G 11^RTT11
;
12 ;;Move Requests to last volume
G 12^RTT11
;
PARSE ;entry point to charge record with 'Y', RTB, RTMV and RTMV0 defined; optionally RTQ defined
;Y=<record IFN>^<associated borrower>^<barcode input[y/n]>
S RT=+Y,RTPROV=$P(Y,"^",2),RTBCIFN=$P(Y,"^",3)
CHG ;Entry pt with RT, RTB, RTMV and RTMV0 defined; optionally RTQ, RTPROV defined
S Y=$P(RTMV0,"^") I $S(Y["FOUND":1,Y["MISSING":1,$D(^RTV(190.2,"AM","m",RT)):0,1:1) S DA=RT,DIE="^RT(",DR="[RT CHARGE]" D ^DIE K DE,DQ D MOVE^RTUTL1:'$D(Y)
Q
;
TYPE K RTMV,RTMV0 S Y=+$O(^DIC(195.3,"AA",+RTAPL,X,0)) I 'Y!($O(^DIC(195.3,"AA",+RTAPL,X,Y)))!('$D(^DIC(195.3,Y,0))) W:'$D(ZTSK) !!,*7," '",X,"' Please check Movement Type file." Q
S RTMV=Y,RTMV0=^DIC(195.3,Y,0)
Q
;
DR F RTI=1:1 Q:'$D(RTY(RTI)) S RT=RTY(RTI) I $D(^RT(RT,0)) S RTE=$P(^(0),"^"),X1=$P(RTDR,"^",2)_$S($D(^DIC(195.2,+$P(^(0),"^",3),0)):$P(^(0),"^"),1:"")_" Vol: "_+$P(^RT(RT,0),"^",7) D DR1
K RT,RTY,RTI Q
;
DR1 D RECHD^RTUTL2 S RT0=^RT(RT,0),DA=RT,DIE="^RT(",DR=$P(RTDR,"^")_$S($D(^DIC(195.2,+$P(RT0,"^",3),0)):$S($P(^(0),"^",16)="y":";12",1:""),1:"") D ^DIE G DR1Q:$D(Y)
S X=^RT(RT,0) G DR1Q:'$D(^RTV(195.9,+$P(X,"^",6),0))!($P(X,"^",6)=$P(RT0,"^",6)) I $D(^RT(RT,"CL")),$P(^("CL"),"^",5)=$P(X,"^",6) G DR1Q
S RTRD(1)="Yes^check in record to new 'home' file room",RTRD(2)="No^not check it in",RTRD("B")=2,RTRD(0)="S",RTRD("A")="Do you want to check in the record to the new home file room? " D SET^RTRD K RTRD G DR1Q:$E(X)'="Y"
S RTB=+$P(^RT(RT,0),"^",6) S X="CHECK-IN" D TYPE G DR1Q:'$D(RTMV) D CHG W:'$D(Y) !?5,"...record has been checked in"
DR1Q K RT0,RTB,RTMV,RTMV0,X Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTT 3873 printed Dec 13, 2024@02:34:54 Page 2
RTT ;MJK/TROY ISC;Record Transaction Option; ; 5/19/87 9:58 AM ;
+1 ;;v 2.0;Record Tracking;;10/22/91
+2 DO DT^DICRW
SET X=$TEXT(+1)
SET DIK="^DOPT("""_$PIECE(X," ;",1)_""","
+3 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)
+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 ;;Create a Label/Record/Volume
+1 GOTO ^RTDPA1
+2 ;
2 ;;Delete a Record
+1 GOTO ^RTDEL
+2 ;
3 ;;Charge-Out Records
+1 KILL RTB
SET X="CHARGE-OUT"
DO TYPE
if '$DATA(RTMV)
GOTO Q
DO CO
if '$DATA(RTFIN)
GOTO 3
KILL RTFIN
GOTO Q
+2 ;
CO IF '$DATA(RTDIV)
DO DIV1^RTPSET
IF '$DATA(RTDIV)
DO MES^RTP4
SET RTFIN=""
GOTO Q
+1 IF RTMV0["TRANSFER TO"
DO DAT^RTTR
if '$DATA(RTPAST)
GOTO Q
+2 IF RTMV0'["CHECK-IN"
DO PND^RTRPT
IF 1
+3 IF '$TEST
DO CPND^RTRPT
+4 KILL RTFIN
IF $SELECT('$DATA(RTB):1,'$DATA(^RTV(195.9,+RTB,0)):1,1:0)
WRITE !
KILL RTB
DO BOR^RTDPA32
IF '$DATA(RTB)
SET RTFIN=""
GOTO Q
+5 if '$DATA(RTPROVFL)
SET RTPROVFL=0
SET RTN=0
KILL ^TMP($JOB,"RT")
DO SEL^RTT3
Q KILL RTC,X1,RTESC,%DT,POP,RTA,I1,RTWND,RTMV,RTMV0,RTN,RTESC,RTPROVFL,Z0
+1 IF '$DATA(RTKEY)
KILL ^TMP($JOB,"RT"),RTPAST,RTB
+2 KILL SSN,N,X,Y,JL,RTAR,Y,I,DIE,DA,DR,RTJST,DR,P
+3 QUIT
+4 ;
4 ;;Re-charge a Record
RC KILL RTB
SET X="RE-CHARGE"
DO TYPE
if '$DATA(RTMV)
GOTO Q
DO CO
if '$DATA(RTFIN)
GOTO 4
KILL RTFIN
GOTO Q
+1 ;
5 ;;Check-In Records
+1 SET X="CHECK-IN"
DO TYPE
if '$DATA(RTMV)
GOTO Q
CI SET Y=$SELECT($DATA(RTFR):+RTFR,1:"")
+1 IF 'Y
SET DIC(0)="IAMEQ"
SET DIC="^RTV(195.9,"
SET DIC("A")="Select Check-In File Room: "
SET DIC("S")="I $P(^(0),U,3)=+RTAPL,$P(^(0),U,13)=""F"" D DICS^RTDPA31"
SET DIC("V")="I $P(Y(0),U,4)=""L"""
DO ^DIC
KILL DIC
if Y<0
QUIT
+2 SET RTB=+Y
DO CO
KILL RTFIN
QUIT
+3 ;
6 ;;Transfer Menu
+1 GOTO ^RTTR
+2 ;
7 ;;Flag Record as Missing
+1 GOTO 7^RTT1
+2 ;
8 ;;Record Charge-out to Patient
+1 GOTO 8^RTT4
+2 ;
9 ;;Update Record's Attributes
UP SET RTSEL="S"
SET DIC(0)="IAEMQ"
DO ^RTDPA
KILL RTBCIFN,RTSEL
if '$DATA(RTY)
GOTO Q
SET RTDR="13//NO;6;11//OK TO RETIRE^Update Record's Attributes: "
DO DR
KILL RTDR
GOTO UP
+1 ;
10 ;;Inactivate/Re-activate Records
+1 WRITE !
SET DIC="^DIC(195.3,"
SET DIC(0)="IAEMQZ"
SET DIC("A")="Select Movement Type: "
SET DIC("S")="I $P(^(0),U,3)=+RTAPL,$P(^(0),U)[""ACTIVATE"""
DO ^DIC
KILL DIC
if Y<0
GOTO Q
SET RTMV=+Y
SET RTMV0=Y(0)
SET RTINACFL=$PIECE(Y(0),"^")["INACTIVATE"
+2 KILL RTB
if RTINACFL
DO CO
if 'RTINACFL
DO CI
KILL RTFIN,RTINACFL,RTB
GOTO Q
+3 ;
11 ;;Multiple volume creation
+1 GOTO 11^RTT11
+2 ;
12 ;;Move Requests to last volume
+1 GOTO 12^RTT11
+2 ;
PARSE ;entry point to charge record with 'Y', RTB, RTMV and RTMV0 defined; optionally RTQ defined
+1 ;Y=<record IFN>^<associated borrower>^<barcode input[y/n]>
+2 SET RT=+Y
SET RTPROV=$PIECE(Y,"^",2)
SET RTBCIFN=$PIECE(Y,"^",3)
CHG ;Entry pt with RT, RTB, RTMV and RTMV0 defined; optionally RTQ, RTPROV defined
+1 SET Y=$PIECE(RTMV0,"^")
IF $SELECT(Y["FOUND":1,Y["MISSING":1,$DATA(^RTV(190.2,"AM","m",RT)):0,1:1)
SET DA=RT
SET DIE="^RT("
SET DR="[RT CHARGE]"
DO ^DIE
KILL DE,DQ
if '$DATA(Y)
DO MOVE^RTUTL1
+2 QUIT
+3 ;
TYPE KILL RTMV,RTMV0
SET Y=+$ORDER(^DIC(195.3,"AA",+RTAPL,X,0))
IF 'Y!($ORDER(^DIC(195.3,"AA",+RTAPL,X,Y)))!('$DATA(^DIC(195.3,Y,0)))
if '$DATA(ZTSK)
WRITE !!,*7," '",X,"' Please check Movement Type file."
QUIT
+1 SET RTMV=Y
SET RTMV0=^DIC(195.3,Y,0)
+2 QUIT
+3 ;
DR FOR RTI=1:1
if '$DATA(RTY(RTI))
QUIT
SET RT=RTY(RTI)
IF $DATA(^RT(RT,0))
SET RTE=$PIECE(^(0),"^")
SET X1=$PIECE(RTDR,"^",2)_$SELECT($DATA(^DIC(195.2,+$PIECE(^(0),"^",3),0)):$PIECE(^(0),"^"),1:"")_" Vol: "_+$PIECE(^RT(RT,0),"^",7)
DO DR1
+1 KILL RT,RTY,RTI
QUIT
+2 ;
DR1 DO RECHD^RTUTL2
SET RT0=^RT(RT,0)
SET DA=RT
SET DIE="^RT("
SET DR=$PIECE(RTDR,"^")_$SELECT($DATA(^DIC(195.2,+$PIECE(RT0,"^",3),0)):$SELECT($PIECE(^(0),"^",16)="y":";12",1:""),1:"")
DO ^DIE
if $DATA(Y)
GOTO DR1Q
+1 SET X=^RT(RT,0)
if '$DATA(^RTV(195.9,+$PIECE(X,"^",6),0))!($PIECE(X,"^",6)=$PIECE(RT0,"^",6))
GOTO DR1Q
IF $DATA(^RT(RT,"CL"))
IF $PIECE(^("CL"),"^",5)=$PIECE(X,"^",6)
GOTO DR1Q
+2 SET RTRD(1)="Yes^check in record to new 'home' file room"
SET RTRD(2)="No^not check it in"
SET RTRD("B")=2
SET RTRD(0)="S"
SET RTRD("A")="Do you want to check in the record to the new home file room? "
DO SET^RTRD
KILL RTRD
if $EXTRACT(X)'="Y"
GOTO DR1Q
+3 SET RTB=+$PIECE(^RT(RT,0),"^",6)
SET X="CHECK-IN"
DO TYPE
if '$DATA(RTMV)
GOTO DR1Q
DO CHG
if '$DATA(Y)
WRITE !?5,"...record has been checked in"
DR1Q KILL RT0,RTB,RTMV,RTMV0,X
QUIT
+1 ;
