RTSM7 ;PKE/ISC-ALBANY ;revoke user borrowing priv on termination
;;2.0;Record Tracking;**49**;10/22/91 ;Build 2
Q
XU Q:'$D(XUDA) S RTDUZ=XUDA D REVOK,KIL Q
;
EN ; per application, revoke borrowing priv , cancel pending requests
I '$D(RTLN) S RTLN=0
S (L0,L)=RTLN+1
S (LO,L)=L0+1 D NOW^%DTC S Y=$E(%,1,12) D D^DIQ K X S X(RTLN+1)=" Terminated User/Borrower Report START DATE/TIME: "_Y
S (L0,L)=L0+5
D UTL,TERM
PRIV ;revoked bor
S L0=L0+1,X(L0)=" "
F RTDUZ=0:0 S RTDUZ=$O(^TMP($J,RTDUZ)) Q:'RTDUZ S RTDUZ0=^(RTDUZ) F RTA=0:0 S RTA=$O(^TMP($J,RTDUZ,RTA)) Q:'RTA S RTAPL=^(RTA) D YYY
;
CAN ;req canc
F RTDUZ=0:0 S RTDUZ=$O(^TMP($J,RTDUZ)) Q:'RTDUZ S RTDUZ0=^(RTDUZ) D XXX
D NOW^%DTC S Y=$E(%,1,12) D D^DIQ K X S X(RTLN+2)=" STOP DATE/TIME: "_Y S X(RTLN+3)=" ",X(RTLN+4)=" "
D UTL Q
YYY S L0=L0+1,L=L+1,X(L0)=" `"_$E(RTDUZ0_"' ",1,20)_" borrowing priviliges are revoked for '"_RTAPL_"'"
D UTL Q
TERM ;
S X1=DT,X2=-3 D C^%DTC S RTDTW=X
; RTW change for RT*2*49 to fix the the run away issue in this subroutine.
S RTDUZB=""
S RTDUZ=0
F S RTDUZB=$O(^VA(200,"B",RTDUZB)) Q:RTDUZB="" D
. F S RTDUZ=$O(^VA(200,"B",RTDUZB,RTDUZ)) Q:'RTDUZ I $D(^(RTDUZ,0)) S RTERM=$P(^(0),"^",11) I RTERM,+RTERM'>DT,RTERM'<RTDTW S RTDUZ0=$P(^(0),"^") D REVOK
Q
KIL K SAVDUZ,RTDUZ,POINT,BPOINT,RTBOR,Z,DIC,DA,DR Q
;
;add on to regular bulletin (the whole application)
;print cancel request on home location printer /or mailgroup
Q
REVOK ;entry with duz to revoke borrowering priv
S BORROW=RTDUZ_";VA(200," D BOR
Q
BOR ;find borrower to revoke for all applications
;check application parameter to revoke/ornot, cancel/ornot
F RTB=0:0 S RTB=$O(^RTV(195.9,"B",BORROW,RTB)) Q:'RTB I $D(^RTV(195.9,RTB,0)) S RTA=$P(^(0),"^",3) D NOTE I $D(^DIC(195.1,RTA,2)),$P(^(2),"^",3)="y" S DA=RTB,DIE="^RTV(195.9,",DR="10///REVOKE" D ^DIE K DE,DQ D CANCEL
Q
NOTE S L0=L0+1,L=L+1
S X(L0)=" `"_$E(RTDUZ0_"' ",1,20)_" has been terminated and is a `"_$S(RTA=1:"MAS",RTA=2:"RAD",1:$P(^DIC(195.1,RTA,0),"^"))_"' Borrower"
D UTL
S:'$D(^TMP($J,RTDUZ)) ^(RTDUZ)=RTDUZ0
Q
CANCEL ; cancel rtq
S:'$D(^TMP($J,RTDUZ,RTA)) ^(RTA)=$S(RTA=1:"MAS",RTA=2:"RAD",1:$S($D(^DIC(195.1,RTA,0)):$P(^(0),"^"),1:""))
Q:'$D(^DIC(195.1,RTA,2)) I $P(^(2),"^",4)'="y" Q
F RTQ=0:0 S RTQ=$O(^RTV(190.1,"ABOR",RTB,RTQ)) Q:'RTQ D CHK
Q
CHK ;rtapl
Q:'$D(^RTV(190.1,RTQ,0)) S RTQ0=^(0)
;
I $P(RTQ0,"^",5)'=RTB Q
;
I $P(RTQ0,"^",6)'="r" Q
;
I $P(RTQ0,"^",10),$P(^RTV(194.2,+$P(RTQ0,"^",10),0),"^",10)=1 Q
;associated requestor
I $P(RTQ0,"^",14) Q
;date/time requested (only pending)
S RDT=$P(RTQ0,"^",4) Q:'RDT
;
Q:'$D(^RT(+RTQ0,0)) S RT0=^(0)
S RTTY=$P(RT0,"^",3),RTH=+$P(RT0,"^",6),RTAPL=$P(RT0,"^",4)
I '$D(RTWND(+RTTY)) D PND^RTRPT
I $P(RDT,".")<RTWND(+RTTY) Q
S RTE=$P(RT0,"^"),RTV=$P(RT0,"^",5),RT=+RTQ0
;need to show what requests were canceled
S ^TMP($J,RTDUZ,RTAPL,RTQ)=RTE_"^"_RTTY_"^"_RTV_"^"_RT_"^"_RTQ_"^"_RTH_"^"_RDT
;
ZZZ S RTSTAT="x" S SAVDUZ=RTDUZ,DA=RTQ,DIE="^RTV(190.1,",DR="[RT CHANGE REQUEST STATUS]" D ^DIE K DE,DQ,RTSTAT S RTDUZ=SAVDUZ Q
Q
XXX F B=0:0 S B=$O(^TMP($J,RTDUZ,B)) Q:'B D B
Q
B I '$O(^TMP($J,RTDUZ,B,0)) Q
S (L,L0)=L0+1+L,X(L0)=" "
S L0=L0+1,X(L0)=" "
S L=L+1,X(L)=" "
S L=L+1,X(L)=" `"_$E(RTDUZ0_"' ",1,20)_" had requests for these Records which are CANCELLED" S L=L+1,X(L)="",$P(X(L),"-",78)=""
S L=L+1,X(L)=" Record Type Vol Rec # Req # Request date/time"
;
F C=0:0 S C=$O(^TMP($J,RTDUZ,B,C)) Q:'C S U0=^(C) D C
D UTL Q
C S L=L+1,Y=$P(U0,"^") D NAME^RTB S RTTY=$P(U0,"^",2),RTTY=$P(^DIC(195.2,RTTY,0),"^",2),RTV=$P(U0,"^",3),RT=$P(U0,"^",4),RTQ=C
S BL="",$P(BL," ",20)="",X(L)=" "_$E(Y_BL,1,20)_" "_$E(RTTY_BL,1,5)_" "_$S($L(RTV):"V",1:" ")_$E(RTV_BL,1,6)_" "_$E(RT_BL,1,12)_" "_$E(RTQ_BL,1,10)
S D=$E($P(U0,"^",7)_"00000",1,12)
S D=$E(D,4,5)_"-"_$E(D,6,7)_" @ "_$E(D,9,10)_":"_$E(D,11,12),X(L)=X(L)_" "_D
I L#10=0 D UTL
Q
UTL F Z=0:0 S Z=$O(X(Z)) Q:'Z S ^TMP($J,"TX",Z,0)=X(Z)
K X Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTSM7 4137 printed Dec 13, 2024@02:34:50 Page 2
RTSM7 ;PKE/ISC-ALBANY ;revoke user borrowing priv on termination
+1 ;;2.0;Record Tracking;**49**;10/22/91 ;Build 2
+2 QUIT
XU if '$DATA(XUDA)
QUIT
SET RTDUZ=XUDA
DO REVOK
DO KIL
QUIT
+1 ;
EN ; per application, revoke borrowing priv , cancel pending requests
+1 IF '$DATA(RTLN)
SET RTLN=0
+2 SET (L0,L)=RTLN+1
+3 SET (LO,L)=L0+1
DO NOW^%DTC
SET Y=$EXTRACT(%,1,12)
DO D^DIQ
KILL X
SET X(RTLN+1)=" Terminated User/Borrower Report START DATE/TIME: "_Y
+4 SET (L0,L)=L0+5
+5 DO UTL
DO TERM
PRIV ;revoked bor
+1 SET L0=L0+1
SET X(L0)=" "
+2 FOR RTDUZ=0:0
SET RTDUZ=$ORDER(^TMP($JOB,RTDUZ))
if 'RTDUZ
QUIT
SET RTDUZ0=^(RTDUZ)
FOR RTA=0:0
SET RTA=$ORDER(^TMP($JOB,RTDUZ,RTA))
if 'RTA
QUIT
SET RTAPL=^(RTA)
DO YYY
+3 ;
CAN ;req canc
+1 FOR RTDUZ=0:0
SET RTDUZ=$ORDER(^TMP($JOB,RTDUZ))
if 'RTDUZ
QUIT
SET RTDUZ0=^(RTDUZ)
DO XXX
+2 DO NOW^%DTC
SET Y=$EXTRACT(%,1,12)
DO D^DIQ
KILL X
SET X(RTLN+2)=" STOP DATE/TIME: "_Y
SET X(RTLN+3)=" "
SET X(RTLN+4)=" "
+3 DO UTL
QUIT
YYY SET L0=L0+1
SET L=L+1
SET X(L0)=" `"_$EXTRACT(RTDUZ0_"' ",1,20)_" borrowing priviliges are revoked for '"_RTAPL_"'"
+1 DO UTL
QUIT
TERM ;
+1 SET X1=DT
SET X2=-3
DO C^%DTC
SET RTDTW=X
+2 ; RTW change for RT*2*49 to fix the the run away issue in this subroutine.
+3 SET RTDUZB=""
+4 SET RTDUZ=0
+5 FOR
SET RTDUZB=$ORDER(^VA(200,"B",RTDUZB))
if RTDUZB=""
QUIT
Begin DoDot:1
+6 FOR
SET RTDUZ=$ORDER(^VA(200,"B",RTDUZB,RTDUZ))
if 'RTDUZ
QUIT
IF $DATA(^(RTDUZ,0))
SET RTERM=$PIECE(^(0),"^",11)
IF RTERM
IF +RTERM'>DT
IF RTERM'<RTDTW
SET RTDUZ0=$PIECE(^(0),"^")
DO REVOK
End DoDot:1
+7 QUIT
KIL KILL SAVDUZ,RTDUZ,POINT,BPOINT,RTBOR,Z,DIC,DA,DR
QUIT
+1 ;
+2 ;add on to regular bulletin (the whole application)
+3 ;print cancel request on home location printer /or mailgroup
+4 QUIT
REVOK ;entry with duz to revoke borrowering priv
+1 SET BORROW=RTDUZ_";VA(200,"
DO BOR
+2 QUIT
BOR ;find borrower to revoke for all applications
+1 ;check application parameter to revoke/ornot, cancel/ornot
+2 FOR RTB=0:0
SET RTB=$ORDER(^RTV(195.9,"B",BORROW,RTB))
if 'RTB
QUIT
IF $DATA(^RTV(195.9,RTB,0))
SET RTA=$PIECE(^(0),"^",3)
DO NOTE
IF $DATA(^DIC(195.1,RTA,2))
IF $PIECE(^(2),"^",3)="y"
SET DA=RTB
SET DIE="^RTV(195.9,"
SET DR="10///REVOKE"
DO ^DIE
KILL DE,DQ
DO CANCEL
+3 QUIT
NOTE SET L0=L0+1
SET L=L+1
+1 SET X(L0)=" `"_$EXTRACT(RTDUZ0_"' ",1,20)_" has been terminated and is a `"_$SELECT(RTA=1:"MAS",RTA=2:"RAD",1:$PIECE(^DIC(195.1,RTA,0),"^"))_"' Borrower"
+2 DO UTL
+3 if '$DATA(^TMP($JOB,RTDUZ))
SET ^(RTDUZ)=RTDUZ0
+4 QUIT
CANCEL ; cancel rtq
+1 if '$DATA(^TMP($JOB,RTDUZ,RTA))
SET ^(RTA)=$SELECT(RTA=1:"MAS",RTA=2:"RAD",1:$SELECT($DATA(^DIC(195.1,RTA,0)):$PIECE(^(0),"^"),1:""))
+2 if '$DATA(^DIC(195.1,RTA,2))
QUIT
IF $PIECE(^(2),"^",4)'="y"
QUIT
+3 FOR RTQ=0:0
SET RTQ=$ORDER(^RTV(190.1,"ABOR",RTB,RTQ))
if 'RTQ
QUIT
DO CHK
+4 QUIT
CHK ;rtapl
+1 if '$DATA(^RTV(190.1,RTQ,0))
QUIT
SET RTQ0=^(0)
+2 ;
+3 IF $PIECE(RTQ0,"^",5)'=RTB
QUIT
+4 ;
+5 IF $PIECE(RTQ0,"^",6)'="r"
QUIT
+6 ;
+7 IF $PIECE(RTQ0,"^",10)
IF $PIECE(^RTV(194.2,+$PIECE(RTQ0,"^",10),0),"^",10)=1
QUIT
+8 ;associated requestor
+9 IF $PIECE(RTQ0,"^",14)
QUIT
+10 ;date/time requested (only pending)
+11 SET RDT=$PIECE(RTQ0,"^",4)
if 'RDT
QUIT
+12 ;
+13 if '$DATA(^RT(+RTQ0,0))
QUIT
SET RT0=^(0)
+14 SET RTTY=$PIECE(RT0,"^",3)
SET RTH=+$PIECE(RT0,"^",6)
SET RTAPL=$PIECE(RT0,"^",4)
+15 IF '$DATA(RTWND(+RTTY))
DO PND^RTRPT
+16 IF $PIECE(RDT,".")<RTWND(+RTTY)
QUIT
+17 SET RTE=$PIECE(RT0,"^")
SET RTV=$PIECE(RT0,"^",5)
SET RT=+RTQ0
+18 ;need to show what requests were canceled
+19 SET ^TMP($JOB,RTDUZ,RTAPL,RTQ)=RTE_"^"_RTTY_"^"_RTV_"^"_RT_"^"_RTQ_"^"_RTH_"^"_RDT
+20 ;
ZZZ SET RTSTAT="x"
SET SAVDUZ=RTDUZ
SET DA=RTQ
SET DIE="^RTV(190.1,"
SET DR="[RT CHANGE REQUEST STATUS]"
DO ^DIE
KILL DE,DQ,RTSTAT
SET RTDUZ=SAVDUZ
QUIT
+1 QUIT
XXX FOR B=0:0
SET B=$ORDER(^TMP($JOB,RTDUZ,B))
if 'B
QUIT
DO B
+1 QUIT
B IF '$ORDER(^TMP($JOB,RTDUZ,B,0))
QUIT
+1 SET (L,L0)=L0+1+L
SET X(L0)=" "
+2 SET L0=L0+1
SET X(L0)=" "
+3 SET L=L+1
SET X(L)=" "
+4 SET L=L+1
SET X(L)=" `"_$EXTRACT(RTDUZ0_"' ",1,20)_" had requests for these Records which are CANCELLED"
SET L=L+1
SET X(L)=""
SET $PIECE(X(L),"-",78)=""
+5 SET L=L+1
SET X(L)=" Record Type Vol Rec # Req # Request date/time"
+6 ;
+7 FOR C=0:0
SET C=$ORDER(^TMP($JOB,RTDUZ,B,C))
if 'C
QUIT
SET U0=^(C)
DO C
+8 DO UTL
QUIT
C SET L=L+1
SET Y=$PIECE(U0,"^")
DO NAME^RTB
SET RTTY=$PIECE(U0,"^",2)
SET RTTY=$PIECE(^DIC(195.2,RTTY,0),"^",2)
SET RTV=$PIECE(U0,"^",3)
SET RT=$PIECE(U0,"^",4)
SET RTQ=C
+1 SET BL=""
SET $PIECE(BL," ",20)=""
SET X(L)=" "_$EXTRACT(Y_BL,1,20)_" "_$EXTRACT(RTTY_BL,1,5)_" "_$SELECT($LENGTH(RTV):"V",1:" ")_$EXTRACT(RTV_BL,1,6)_" "_$EXTRACT(RT_BL,1,12)_" "_$EXTRACT(RTQ_BL,1,10)
+2 SET D=$EXTRACT($PIECE(U0,"^",7)_"00000",1,12)
+3 SET D=$EXTRACT(D,4,5)_"-"_$EXTRACT(D,6,7)_" @ "_$EXTRACT(D,9,10)_":"_$EXTRACT(D,11,12)
SET X(L)=X(L)_" "_D
+4 IF L#10=0
DO UTL
+5 QUIT
UTL FOR Z=0:0
SET Z=$ORDER(X(Z))
if 'Z
QUIT
SET ^TMP($JOB,"TX",Z,0)=X(Z)
+1 KILL X
QUIT
