- 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 Jan 18, 2025@03:35:27 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