RTP4 ;MJK/TROY ISC;Charge Out Pull List; ; 5/15/87 11:06 AM ;
;;2.0;Record Tracking;**3,46**;10/22/91 ;Build 46
6 ;Charge Out Pull List
I '$D(RTAPL) D MES Q
S RTRD(1)="Yes^designate requests as 'not fillable'",RTRD(2)="No^not designate any requests as 'not fillable'",RTRD("B")=2,RTRD(0)="S",RTRD("A")="Do you wish to first designate some requests as 'not fillable'? "
D SET^RTRD K RTRD Q:$E(X)="^" I $E(X)="Y" D 5^RTP1
D DIV G Q:'$D(RTDV) S RTMES="CHARGED OUT" D PULL^RTP6 K RTMES G Q:'$D(RTPULL)
;ask holding area
K RTB D BOR^RTP40 G Q:$D(RTESC) I $D(RTB) S RTHOLD=""
;ask for perpetual records if RR
S (RTYES,RTACCN)=""
I $D(RTHOLD)!('$D(RTIRE))
E D BOR^RTP41 K DIC G Q:$S('$D(RTB):1,RTYES["^":1,RTACCN["^":1,1:0)
;
I RTPULL="ALL" W !!?5,"*** Printing an 'UPDATE' listing maybe a good idea ***",!?5,"*** before charging out these records. ***"
S RTRD(1)="Yes^continue charge out process",RTRD(2)="No^stop charge out process",RTRD("A")="Are you sure you want to 'CHARGE OUT' these records? ",RTRD("B")=2,RTRD(0)="S" D SET^RTRD K RTRD G Q:$E(X)'="Y"
;
D NOW^%DTC S RTQUEDT=%,RTVAR="RTACCN^RTFR^RTYES^RTAPL^RTQUEDT^RTDT^RTDV^RTPULL"_$S($D(RTB):"^RTB",1:"")_$S($D(RTIRE):"^RTIRE",1:"")_$S($D(RTHOLD):"^RTHOLD",1:""),RTDESC="Charge Out Pull List",RTPGM="START^RTP4" D ZIS^RTUTL G Q:POP
;
START U IO K ^TMP($J),RTP0 S RTBKGRD="",RTALL=+RTPULL,RTBEG=RTDT-.0001,RTEND=$S(RTDT[".":RTDT,1:RTDT_".2359") I $D(RTB),$D(RTHOLD) D ^RTP40 G Q
I $D(RTB),$D(RTIRE) S ^TMP($J,"RTREQUESTS","RTB")=RTB K RTB
S RTAG="SCAN" D CHK W @IOF F RTLIST="RTCANCEL","RTMISS" I $D(^TMP($J,RTLIST)) D LIST^RTP41
W @IOF,!,"PULL LIST CHARGE-OUT LOG" D NOW^%DTC S Y=$E(%,1,12) D D^DIQ W ?51,"RUN DATE: ",Y D LINE^RTUTL3 W ! S RTAG="FILL" D CHK
;now go and make perpetual records
I RTYES,$D(RTIRE),'$D(RTHOLD) D PERP^RTQ41
;
Q K RTACCN,RTYES,RTHOLD,DIC,RTAG,DR,RTESC,RTBKGRD,RTPGM,RTPLTY,RTVAR,RTLIST,RTN,RTSSN,RTSTAT,SAVX,RTB,RTC,RTBEG,RTEND,RTDESC,RTALL,RTQUEDT,RTPULL,RTPULL0,RTDV,RTDT,RTDEV
K ^TMP($J)
D CLOSE^RTUTL K %DT,DA,D0,DIE,N,A
K Y,RT,J,RTE,X1,P Q
;rtp0,"^",10 is pull list type
CHK I 'RTALL F RTPDT=RTBEG:0 S RTPDT=$O(^RTV(194.2,"C",RTPDT)) Q:'RTPDT!(RTPDT>RTEND) F RTPULL=0:0 S RTPULL=$O(^RTV(194.2,"C",RTPDT,RTPULL)) Q:'RTPULL I $D(^RTV(194.2,RTPULL,0)) S RTP0=^(0) I "13"[$E($P(RTP0,"^",10)_"0") D CHKPULL D:Y @RTAG
I $D(^RTV(194.2,+RTALL,0)) S RTPULL=+RTALL,RTP0=^(0) D CHKPULL D:Y @RTAG
K RTPULL,RTP0,RTPDT Q
;^6 canceled, apl, div
CHKPULL S Y=0,X=RTP0 Q:$S($P(X,"^",6)="x":1,$P(X,"^",15)'=+RTAPL:1,$P(X,"^",12)'=RTDV:1,1:0) S RTPLTY=$P(X,"^",10)
I '$D(RTIRE),RTPLTY'=3 S Y=1 Q
I $D(RTIRE),RTPLTY=3 S Y=1 Q
Q
SCAN F RTN=0:0 K RT S RTN=$O(^RTV(190.1,"AP",RTPULL,RTN)) Q:'RTN I $D(^RTV(190.1,RTN,0)) S RTQ=RTN,RTQ0=^(0),RT=+RTQ0 D SET
Q
;
SET I $P(RTQ0,"^",6)="x" S ^TMP($J,"RTCANCEL",$P(RTP0,"^"),RTQ)=RTQ0 Q
I $D(^RTV(190.2,"AM","m",RT))!($D(^RTV(190.2,"AM","s",RT))) S ^TMP($J,"RTMISS",$P(RTP0,"^"),RTQ)=RTQ0 Q
S X=+$P(RTQ0,"^",4) Q:'X S:'$D(^TMP($J,"RTREQUESTS",RT)) ^(RT)=X_"^"_RTQ S:X<^(RT) ^(RT)=X_"^"_RTQ ;;;Q
;rte=^(0)^1
I RTYES,$D(RTIRE),$D(RTPLTY),RTPLTY=3,$D(^RT(RT,0)) S X=$P(^(0),"^") I X]"",'$D(^TMP($J,"RTE",X)) S ^(X)="" Q
Q
;
DIV ;Entry point to determine if pull function is allowed
; with RTAPL and RTDIV defined
K RTDV,RTDEV I $S('$D(RTDIV):1,'$D(RTFR):1,'$D(^DIC(4,+RTDIV,0)):1,'$D(^DIC(195.1,+RTAPL,"INST",+RTDIV)):1,1:0) D MES Q
W !!,"Institution: ",$P(^DIC(4,+RTDIV,0),"^") S RTDV=RTDIV,RTDEV=$P(RTFR,"^",6) Q
;
MES W !!?3,*7,"This function requires the user to be signed onto the",!?3,"system with INSTITUTION parameters defined. Please use",!?3,"the Record Tracking Total System Menu to access this option." Q
;
FILL S RTCOMR="Pull List: "_$P(RTP0,"^") F RTQ=0:0 S RTQ=$O(^RTV(190.1,"AP",RTPULL,RTQ)) Q:'RTQ I $D(^RTV(190.1,RTQ,0)),$P(^(0),"^",6)="r" S RTQ0=^(0) D FILL1
K RTQ,RTQ0,RTCOMR S RTSTAT="c" D STAT^RTP W !?3,"...'",$P(RTP0,"^"),"' pull list has been charged out." Q
;
FILL1 Q:$S('$D(^RT(+RTQ0,"CL")):1,+$P(^("CL"),"^",6)>RTQUEDT:1,$P(RTQ0,"^",6)'="r":1,1:0) I $P(RTP0,"^",16),$P(^("CL"),"^",5)'=$P(RTP0,"^",16) Q
S RT=+RTQ0 I $D(^TMP($J,"RTREQUESTS",RT)),$P(^(RT),"^",2)=RTQ D:RTPLTY'=3 FILL^RTQ4 D:RTPLTY=3 FILL^RTQ41
K RT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTP4 4282 printed Apr 09, 2024@21:36:18 Page 2
RTP4 ;MJK/TROY ISC;Charge Out Pull List; ; 5/15/87 11:06 AM ;
+1 ;;2.0;Record Tracking;**3,46**;10/22/91 ;Build 46
6 ;Charge Out Pull List
+1 IF '$DATA(RTAPL)
DO MES
QUIT
+2 SET RTRD(1)="Yes^designate requests as 'not fillable'"
SET RTRD(2)="No^not designate any requests as 'not fillable'"
SET RTRD("B")=2
SET RTRD(0)="S"
SET RTRD("A")="Do you wish to first designate some requests as 'not fillable'? "
+3 DO SET^RTRD
KILL RTRD
if $EXTRACT(X)="^"
QUIT
IF $EXTRACT(X)="Y"
DO 5^RTP1
+4 DO DIV
if '$DATA(RTDV)
GOTO Q
SET RTMES="CHARGED OUT"
DO PULL^RTP6
KILL RTMES
if '$DATA(RTPULL)
GOTO Q
+5 ;ask holding area
+6 KILL RTB
DO BOR^RTP40
if $DATA(RTESC)
GOTO Q
IF $DATA(RTB)
SET RTHOLD=""
+7 ;ask for perpetual records if RR
+8 SET (RTYES,RTACCN)=""
+9 IF $DATA(RTHOLD)!('$DATA(RTIRE))
+10 IF '$TEST
DO BOR^RTP41
KILL DIC
if $SELECT('$DATA(RTB):1,RTYES["^":1,RTACCN["^":1,1:0)
GOTO Q
+11 ;
+12 IF RTPULL="ALL"
WRITE !!?5,"*** Printing an 'UPDATE' listing maybe a good idea ***",!?5,"*** before charging out these records. ***"
+13 SET RTRD(1)="Yes^continue charge out process"
SET RTRD(2)="No^stop charge out process"
SET RTRD("A")="Are you sure you want to 'CHARGE OUT' these records? "
SET RTRD("B")=2
SET RTRD(0)="S"
DO SET^RTRD
KILL RTRD
if $EXTRACT(X)'="Y"
GOTO Q
+14 ;
+15 DO NOW^%DTC
SET RTQUEDT=%
SET RTVAR="RTACCN^RTFR^RTYES^RTAPL^RTQUEDT^RTDT^RTDV^RTPULL"_$SELECT($DATA(RTB):"^RTB",1:"")_$SELECT($DATA(RTIRE):"^RTIRE",1:"")_$SELECT($DATA(RTHOLD):"^RTHOLD",1:"")
SET RTDESC="Charge Out Pull List"
SET RTPGM="START^RTP4"
DO ZIS^RTUTL
if POP
GOTO Q
+16 ;
START USE IO
KILL ^TMP($JOB),RTP0
SET RTBKGRD=""
SET RTALL=+RTPULL
SET RTBEG=RTDT-.0001
SET RTEND=$SELECT(RTDT[".":RTDT,1:RTDT_".2359")
IF $DATA(RTB)
IF $DATA(RTHOLD)
DO ^RTP40
GOTO Q
+1 IF $DATA(RTB)
IF $DATA(RTIRE)
SET ^TMP($JOB,"RTREQUESTS","RTB")=RTB
KILL RTB
+2 SET RTAG="SCAN"
DO CHK
WRITE @IOF
FOR RTLIST="RTCANCEL","RTMISS"
IF $DATA(^TMP($JOB,RTLIST))
DO LIST^RTP41
+3 WRITE @IOF,!,"PULL LIST CHARGE-OUT LOG"
DO NOW^%DTC
SET Y=$EXTRACT(%,1,12)
DO D^DIQ
WRITE ?51,"RUN DATE: ",Y
DO LINE^RTUTL3
WRITE !
SET RTAG="FILL"
DO CHK
+4 ;now go and make perpetual records
+5 IF RTYES
IF $DATA(RTIRE)
IF '$DATA(RTHOLD)
DO PERP^RTQ41
+6 ;
Q KILL RTACCN,RTYES,RTHOLD,DIC,RTAG,DR,RTESC,RTBKGRD,RTPGM,RTPLTY,RTVAR,RTLIST,RTN,RTSSN,RTSTAT,SAVX,RTB,RTC,RTBEG,RTEND,RTDESC,RTALL,RTQUEDT,RTPULL,RTPULL0,RTDV,RTDT,RTDEV
+1 KILL ^TMP($JOB)
+2 DO CLOSE^RTUTL
KILL %DT,DA,D0,DIE,N,A
+3 KILL Y,RT,J,RTE,X1,P
QUIT
+4 ;rtp0,"^",10 is pull list type
CHK IF 'RTALL
FOR RTPDT=RTBEG:0
SET RTPDT=$ORDER(^RTV(194.2,"C",RTPDT))
if 'RTPDT!(RTPDT>RTEND)
QUIT
FOR RTPULL=0:0
SET RTPULL=$ORDER(^RTV(194.2,"C",RTPDT,RTPULL))
if 'RTPULL
QUIT
IF $DATA(^RTV(194.2,RTPULL,0))
SET RTP0=^(0)
IF "13"[$EXTRACT($PIECE(RTP0,"^",10)_"0")
DO CHKPULL
if Y
DO @RTAG
+1 IF $DATA(^RTV(194.2,+RTALL,0))
SET RTPULL=+RTALL
SET RTP0=^(0)
DO CHKPULL
if Y
DO @RTAG
+2 KILL RTPULL,RTP0,RTPDT
QUIT
+3 ;^6 canceled, apl, div
CHKPULL SET Y=0
SET X=RTP0
if $SELECT($PIECE(X,"^",6)="x"
QUIT
SET RTPLTY=$PIECE(X,"^",10)
+1 IF '$DATA(RTIRE)
IF RTPLTY'=3
SET Y=1
QUIT
+2 IF $DATA(RTIRE)
IF RTPLTY=3
SET Y=1
QUIT
+3 QUIT
SCAN FOR RTN=0:0
KILL RT
SET RTN=$ORDER(^RTV(190.1,"AP",RTPULL,RTN))
if 'RTN
QUIT
IF $DATA(^RTV(190.1,RTN,0))
SET RTQ=RTN
SET RTQ0=^(0)
SET RT=+RTQ0
DO SET
+1 QUIT
+2 ;
SET IF $PIECE(RTQ0,"^",6)="x"
SET ^TMP($JOB,"RTCANCEL",$PIECE(RTP0,"^"),RTQ)=RTQ0
QUIT
+1 IF $DATA(^RTV(190.2,"AM","m",RT))!($DATA(^RTV(190.2,"AM","s",RT)))
SET ^TMP($JOB,"RTMISS",$PIECE(RTP0,"^"),RTQ)=RTQ0
QUIT
+2 ;;;Q
SET X=+$PIECE(RTQ0,"^",4)
if 'X
QUIT
if '$DATA(^TMP($JOB,"RTREQUESTS",RT))
SET ^(RT)=X_"^"_RTQ
if X<^(RT)
SET ^(RT)=X_"^"_RTQ
+3 ;rte=^(0)^1
+4 IF RTYES
IF $DATA(RTIRE)
IF $DATA(RTPLTY)
IF RTPLTY=3
IF $DATA(^RT(RT,0))
SET X=$PIECE(^(0),"^")
IF X]""
IF '$DATA(^TMP($JOB,"RTE",X))
SET ^(X)=""
QUIT
+5 QUIT
+6 ;
DIV ;Entry point to determine if pull function is allowed
+1 ; with RTAPL and RTDIV defined
+2 KILL RTDV,RTDEV
IF $SELECT('$DATA(RTDIV):1,'$DATA(RTFR):1,'$DATA(^DIC(4,+RTDIV,0)):1,'$DATA(^DIC(195.1,+RTAPL,"INST",+RTDIV)):1,1:0)
DO MES
QUIT
+3 WRITE !!,"Institution: ",$PIECE(^DIC(4,+RTDIV,0),"^")
SET RTDV=RTDIV
SET RTDEV=$PIECE(RTFR,"^",6)
QUIT
+4 ;
MES WRITE !!?3,*7,"This function requires the user to be signed onto the",!?3,"system with INSTITUTION parameters defined. Please use",!?3,"the Record Tracking Total System Menu to access this option."
QUIT
+1 ;
FILL SET RTCOMR="Pull List: "_$PIECE(RTP0,"^")
FOR RTQ=0:0
SET RTQ=$ORDER(^RTV(190.1,"AP",RTPULL,RTQ))
if 'RTQ
QUIT
IF $DATA(^RTV(190.1,RTQ,0))
IF $PIECE(^(0),"^",6)="r"
SET RTQ0=^(0)
DO FILL1
+1 KILL RTQ,RTQ0,RTCOMR
SET RTSTAT="c"
DO STAT^RTP
WRITE !?3,"...'",$PIECE(RTP0,"^"),"' pull list has been charged out."
QUIT
+2 ;
FILL1 if $SELECT('$DATA(^RT(+RTQ0,"CL"))
QUIT
IF $PIECE(RTP0,"^",16)
IF $PIECE(^("CL"),"^",5)'=$PIECE(RTP0,"^",16)
QUIT
+1 SET RT=+RTQ0
IF $DATA(^TMP($JOB,"RTREQUESTS",RT))
IF $PIECE(^(RT),"^",2)=RTQ
if RTPLTY'=3
DO FILL^RTQ4
if RTPLTY=3
DO FILL^RTQ41
+2 KILL RT
QUIT
