- RTDEL ;TROY ISC/MJK-Delete a Record; ; 5/7/87 10:08 AM ;
- ;;v 2.0;Record Tracking;;10/22/91
- DEL W ! S RTINACFL="",DIC(0)="AZEMQ",RTSEL="" D ^RTDPA K RTINACFL,DIC,RTESC,RTY,RTC G DELQ:Y<0 S RT=+Y,RT0=Y(0),V=+$P(RT0,"^",7),P=$S(V=1:RT,1:+$P(RT0,"^",5)),T=+$P(RT0,"^",3) G DEL:'P
- S V1=0,RTTOV1=0 F I=0:0 S I=$O(^RT("P",P,I)) Q:'I I $D(^RT(I,0)),$P(^(0),"^",7)>V1 S V1=+$P(^(0),"^",7),RTTOV1=I
- I V1>V W !!?5,*7,"This record is volume '",V,"' of a '",V1,"' record set.",!?12,"...no deletion is allowed." G DEL
- S V1=0,RTTO=RTTOV1 F I=0:0 S I=$O(^RT("P",P,I)) Q:'I I RTTOV1'=I,$D(^RT(I,0)),$P(^(0),"^",7)>V1 S V1=+$P(^(0),"^",7),RTTO=I
- I RTTO=RTTOV1 S RTTO=P
- I V>1,RTTO I $D(^RT(+RTTO,0)) S RTVOL=$P(^(0),"^",7)
- E W !!?5,"There is no record/volume to transfer requests to .." S RTTO=0
- I RTTO S Y=T D TYPE1^RTUTL I '$D(RTTY) W !!?5,"Unknown Record type" K RTVOL S RTTO=0
- I RTTO S RTPAR=P,RTFROM=RT,RT=RTTO D RTDEL1 S RT=RTFROM K RTFROM I $D(RTESC) K RTESC,RT G DEL
- S Y=$P(RT0,"^") D NAME^RTB W !!,"Record Chosen: ",Y,"'s ",$S($D(^DIC(195.2,+$P(RT0,"^",3),0)):$P(^(0),"^"),1:"UNKNOWN")," [Volume: ",+$P(RT0,"^",7),"]"
- W !!,"Deletion of this record will also cause the following to be deleted:",!?10,"- any requests for the record",!?10,"- any missing record log entries",!?10,"- all movement history log entries"
- S RTRD(1)="Yes^delete record",RTRD(2)="No^stop the deletion process",RTRD("B")=2,RTRD(0)="S",RTRD("A")="Are you sure you want to delete this record? " D SET^RTRD K RTRD G DEL:$E(X)'="Y"
- W !,"Deletion process beginning..."
- F RTQ=0:0 S RTQ=$O(^RTV(190.1,"B",RT,RTQ)) Q:'RTQ D RTQ S DA=RTQ,DIK="^RTV(190.1," D ^DIK W "."
- F RTDIK=190.2,190.3 F RTI=0:0 S RTI=$O(^RTV(RTDIK,"B",RT,RTI)) Q:'RTI S DA=RTI,DIK="^RTV("_RTDIK_"," D ^DIK W "."
- S XMB="RT RECORD DELETION",Y=$P(RT0,"^") D NAME^RTB S XMB(1)=Y,XMB(2)=$S($D(^DIC(195.2,+$P(RT0,"^",3),0)):$P(^(0),"^"),1:"UNKNOWN"),XMB(3)=+$P(RT0,"^",7),XMB(4)=RT,XMB(5)=$S($D(^VA(200,DUZ,0)):$P(^(0),"^"),1:"UNKNOWN")
- D NOW^%DTC S Y=$E(%,1,12) D D^DIQ S XMB(6)=Y D SEND^RTT2 K XMB
- S DA=RT,DIK="^RT(" D ^DIK W !?10,"...deletion complete"
- DELQ K RTDIK,RTI,RT,V,V1
- K T,RTBCIFN,RTSEL,RTTOV1,RT0,RTFROM,%,%H,%Y,%YV,DA,DIC1,DIK,DIY,DIYS,N,POP
- K X,Y,RTTO,RTQ Q
- RTQ K RTQ1 G SC:'$D(^RTV(190.1,"APAR",RTQ)) S RTQ1=+$O(^(RTQ,0)) S DA=RTQ1,DR="11///@",DIE="^RTV(190.1," D ^DIE K DE,DQ
- F RTQ2=0:0 S RTQ2=$O(^RTV(190.1,"APAR",RTQ,RTQ2)) Q:'RTQ2 S DA=RTQ2,DR="11////"_RTQ1,DIE="^RTV(190.1," D ^DIE K DE,DQ
- SC Q:'$D(^RTV(190.1,RTQ,0)) S X=^(0) Q:'$D(^RTV(195.9,+$P(X,"^",5),0)) S X1=^(0) Q:'$D(^SC(+$P(X1,"^",2),0)) S SDTTM=+$P(X,"^",4),SDSC=+$P(X1,"^",2)
- F SDPL=0:0 S SDPL=$O(^SC(SDSC,"S",SDTTM,1,SDPL)) Q:'SDPL I $D(^(SDPL,"RTR")),+^("RTR")=RTQ S ^("RTR")=$S($D(RTQ1):RTQ1,1:"") Q
- K SDSC,SDTTM,SDPL,RTQ1,RTQ2,DR,DIE,X1,X Q
- ;
- RTDEL1 D EN K X,P,Z,RDT,RTV0,RTWND
- K RTTO,RTPAR,RTVOL,RTTY,RTSEL Q
- EN S RTRD(1)="Yes^transfer Requests to Record/Volume "_RTVOL
- S RTRD(2)="No^not change the Record/Volume(s) Requested."
- S RTRD("A")="Pending Requests can be transferred to Record/Volume ,"_RTVOL_$C(13,10)_" Transfer Requests to Volume '"_RTVOL_"' ? "
- ;
- S RTRD(0)="S",RTRD("B")=2 D SET^RTRD K RTRD S X=$E(X) S:X["^" RTESC="" I X'="Y" Q
- ;get pend cut
- Q:'$D(RTTY) D PND^RTRPT Q:'$D(RTWND(+RTTY))
- ;get requests
- GET S RTV0=RTFROM
- ;z=da
- FIND F Z=0:0 S Z=$O(^RTV(190.1,"B",RTV0,Z)) Q:'Z D REC L -^RTV(190.1,Z)
- QUIT
- ;
- REC I $D(^RTV(190.1,Z,0)),$D(^RT(+^RTV(190.1,Z,0))) L +^RTV(190.1,Z):1 I '$T G REC
- I '$D(^RTV(190.1,Z,0))!('$D(^RT(+^RTV(190.1,Z,0)))) Q
- ;only requests,pending
- S RDT=+$P(^RTV(190.1,Z,0),"^",4) Q:'RDT I $P(RDT,".")<RTWND(+RTTY) Q
- I $P(^RTV(190.1,Z,0),"^",6)'="r" Q
- S $P(^RTV(190.1,Z,0),"^",1)=RT,^RTV(190.1,"B",RT,Z)="" K ^RTV(190.1,"B",RTV0,Z) W " ." R X:0
- ;date/time needed
- DAT I RDT,$D(^RTV(190.1,"AC",RTV0,$P(RDT,"."),Z)) S ^RTV(190.1,"AC",RT,$P(RDT,"."),Z)="" K ^RTV(190.1,"AC",RTV0,$P(RDT,"."),Z)
- ;
- ;pull list
- PUL S P=+$P(^RTV(190.1,Z,0),"^",10)
- I P,$D(^RTV(190.1,"AP1",P,RTV0,Z)) S ^RTV(190.1,"AP1",P,RT,Z)="" K ^RTV(190.1,"AP1",P,RTV0,Z)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTDEL 4096 printed Feb 19, 2025@00:00:20 Page 2
- RTDEL ;TROY ISC/MJK-Delete a Record; ; 5/7/87 10:08 AM ;
- +1 ;;v 2.0;Record Tracking;;10/22/91
- DEL WRITE !
- SET RTINACFL=""
- SET DIC(0)="AZEMQ"
- SET RTSEL=""
- DO ^RTDPA
- KILL RTINACFL,DIC,RTESC,RTY,RTC
- if Y<0
- GOTO DELQ
- SET RT=+Y
- SET RT0=Y(0)
- SET V=+$PIECE(RT0,"^",7)
- SET P=$SELECT(V=1:RT,1:+$PIECE(RT0,"^",5))
- SET T=+$PIECE(RT0,"^",3)
- if 'P
- GOTO DEL
- +1 SET V1=0
- SET RTTOV1=0
- FOR I=0:0
- SET I=$ORDER(^RT("P",P,I))
- if 'I
- QUIT
- IF $DATA(^RT(I,0))
- IF $PIECE(^(0),"^",7)>V1
- SET V1=+$PIECE(^(0),"^",7)
- SET RTTOV1=I
- +2 IF V1>V
- WRITE !!?5,*7,"This record is volume '",V,"' of a '",V1,"' record set.",!?12,"...no deletion is allowed."
- GOTO DEL
- +3 SET V1=0
- SET RTTO=RTTOV1
- FOR I=0:0
- SET I=$ORDER(^RT("P",P,I))
- if 'I
- QUIT
- IF RTTOV1'=I
- IF $DATA(^RT(I,0))
- IF $PIECE(^(0),"^",7)>V1
- SET V1=+$PIECE(^(0),"^",7)
- SET RTTO=I
- +4 IF RTTO=RTTOV1
- SET RTTO=P
- +5 IF V>1
- IF RTTO
- IF $DATA(^RT(+RTTO,0))
- SET RTVOL=$PIECE(^(0),"^",7)
- +6 IF '$TEST
- WRITE !!?5,"There is no record/volume to transfer requests to .."
- SET RTTO=0
- +7 IF RTTO
- SET Y=T
- DO TYPE1^RTUTL
- IF '$DATA(RTTY)
- WRITE !!?5,"Unknown Record type"
- KILL RTVOL
- SET RTTO=0
- +8 IF RTTO
- SET RTPAR=P
- SET RTFROM=RT
- SET RT=RTTO
- DO RTDEL1
- SET RT=RTFROM
- KILL RTFROM
- IF $DATA(RTESC)
- KILL RTESC,RT
- GOTO DEL
- +9 SET Y=$PIECE(RT0,"^")
- DO NAME^RTB
- WRITE !!,"Record Chosen: ",Y,"'s ",$SELECT($DATA(^DIC(195.2,+$PIECE(RT0,"^",3),0)):$PIECE(^(0),"^"),1:"UNKNOWN")," [Volume: ",+$PIECE(RT0,"^",7),"]"
- +10 WRITE !!,"Deletion of this record will also cause the following to be deleted:",!?10,"- any requests for the record",!?10,"- any missing record log entries",!?10,"- all movement history log entries"
- +11 SET RTRD(1)="Yes^delete record"
- SET RTRD(2)="No^stop the deletion process"
- SET RTRD("B")=2
- SET RTRD(0)="S"
- SET RTRD("A")="Are you sure you want to delete this record? "
- DO SET^RTRD
- KILL RTRD
- if $EXTRACT(X)'="Y"
- GOTO DEL
- +12 WRITE !,"Deletion process beginning..."
- +13 FOR RTQ=0:0
- SET RTQ=$ORDER(^RTV(190.1,"B",RT,RTQ))
- if 'RTQ
- QUIT
- DO RTQ
- SET DA=RTQ
- SET DIK="^RTV(190.1,"
- DO ^DIK
- WRITE "."
- +14 FOR RTDIK=190.2,190.3
- FOR RTI=0:0
- SET RTI=$ORDER(^RTV(RTDIK,"B",RT,RTI))
- if 'RTI
- QUIT
- SET DA=RTI
- SET DIK="^RTV("_RTDIK_","
- DO ^DIK
- WRITE "."
- +15 SET XMB="RT RECORD DELETION"
- SET Y=$PIECE(RT0,"^")
- DO NAME^RTB
- SET XMB(1)=Y
- SET XMB(2)=$SELECT($DATA(^DIC(195.2,+$PIECE(RT0,"^",3),0)):$PIECE(^(0),"^"),1:"UNKNOWN")
- SET XMB(3)=+$PIECE(RT0,"^",7)
- SET XMB(4)=RT
- SET XMB(5)=$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),"^"),1:"UNKNOWN")
- +16 DO NOW^%DTC
- SET Y=$EXTRACT(%,1,12)
- DO D^DIQ
- SET XMB(6)=Y
- DO SEND^RTT2
- KILL XMB
- +17 SET DA=RT
- SET DIK="^RT("
- DO ^DIK
- WRITE !?10,"...deletion complete"
- DELQ KILL RTDIK,RTI,RT,V,V1
- +1 KILL T,RTBCIFN,RTSEL,RTTOV1,RT0,RTFROM,%,%H,%Y,%YV,DA,DIC1,DIK,DIY,DIYS,N,POP
- +2 KILL X,Y,RTTO,RTQ
- QUIT
- RTQ KILL RTQ1
- if '$DATA(^RTV(190.1,"APAR",RTQ))
- GOTO SC
- SET RTQ1=+$ORDER(^(RTQ,0))
- SET DA=RTQ1
- SET DR="11///@"
- SET DIE="^RTV(190.1,"
- DO ^DIE
- KILL DE,DQ
- +1 FOR RTQ2=0:0
- SET RTQ2=$ORDER(^RTV(190.1,"APAR",RTQ,RTQ2))
- if 'RTQ2
- QUIT
- SET DA=RTQ2
- SET DR="11////"_RTQ1
- SET DIE="^RTV(190.1,"
- DO ^DIE
- KILL DE,DQ
- SC if '$DATA(^RTV(190.1,RTQ,0))
- QUIT
- SET X=^(0)
- if '$DATA(^RTV(195.9,+$PIECE(X,"^",5),0))
- QUIT
- SET X1=^(0)
- if '$DATA(^SC(+$PIECE(X1,"^",2),0))
- QUIT
- SET SDTTM=+$PIECE(X,"^",4)
- SET SDSC=+$PIECE(X1,"^",2)
- +1 FOR SDPL=0:0
- SET SDPL=$ORDER(^SC(SDSC,"S",SDTTM,1,SDPL))
- if 'SDPL
- QUIT
- IF $DATA(^(SDPL,"RTR"))
- IF +^("RTR")=RTQ
- SET ^("RTR")=$SELECT($DATA(RTQ1):RTQ1,1:"")
- QUIT
- +2 KILL SDSC,SDTTM,SDPL,RTQ1,RTQ2,DR,DIE,X1,X
- QUIT
- +3 ;
- RTDEL1 DO EN
- KILL X,P,Z,RDT,RTV0,RTWND
- +1 KILL RTTO,RTPAR,RTVOL,RTTY,RTSEL
- QUIT
- EN SET RTRD(1)="Yes^transfer Requests to Record/Volume "_RTVOL
- +1 SET RTRD(2)="No^not change the Record/Volume(s) Requested."
- +2 SET RTRD("A")="Pending Requests can be transferred to Record/Volume ,"_RTVOL_$CHAR(13,10)_" Transfer Requests to Volume '"_RTVOL_"' ? "
- +3 ;
- +4 SET RTRD(0)="S"
- SET RTRD("B")=2
- DO SET^RTRD
- KILL RTRD
- SET X=$EXTRACT(X)
- if X["^"
- SET RTESC=""
- IF X'="Y"
- QUIT
- +5 ;get pend cut
- +6 if '$DATA(RTTY)
- QUIT
- DO PND^RTRPT
- if '$DATA(RTWND(+RTTY))
- QUIT
- +7 ;get requests
- GET SET RTV0=RTFROM
- +1 ;z=da
- FIND FOR Z=0:0
- SET Z=$ORDER(^RTV(190.1,"B",RTV0,Z))
- if 'Z
- QUIT
- DO REC
- LOCK -^RTV(190.1,Z)
- +1 QUIT
- +2 ;
- REC IF $DATA(^RTV(190.1,Z,0))
- IF $DATA(^RT(+^RTV(190.1,Z,0)))
- LOCK +^RTV(190.1,Z):1
- IF '$TEST
- GOTO REC
- +1 IF '$DATA(^RTV(190.1,Z,0))!('$DATA(^RT(+^RTV(190.1,Z,0))))
- QUIT
- +2 ;only requests,pending
- +3 SET RDT=+$PIECE(^RTV(190.1,Z,0),"^",4)
- if 'RDT
- QUIT
- IF $PIECE(RDT,".")<RTWND(+RTTY)
- QUIT
- +4 IF $PIECE(^RTV(190.1,Z,0),"^",6)'="r"
- QUIT
- +5 SET $PIECE(^RTV(190.1,Z,0),"^",1)=RT
- SET ^RTV(190.1,"B",RT,Z)=""
- KILL ^RTV(190.1,"B",RTV0,Z)
- WRITE " ."
- READ X:0
- +6 ;date/time needed
- DAT IF RDT
- IF $DATA(^RTV(190.1,"AC",RTV0,$PIECE(RDT,"."),Z))
- SET ^RTV(190.1,"AC",RT,$PIECE(RDT,"."),Z)=""
- KILL ^RTV(190.1,"AC",RTV0,$PIECE(RDT,"."),Z)
- +1 ;
- +2 ;pull list
- PUL SET P=+$PIECE(^RTV(190.1,Z,0),"^",10)
- +1 IF P
- IF $DATA(^RTV(190.1,"AP1",P,RTV0,Z))
- SET ^RTV(190.1,"AP1",P,RT,Z)=""
- KILL ^RTV(190.1,"AP1",P,RTV0,Z)
- +2 QUIT