RTP3 ;MJK/TROY ISC,JLU/TROY ISC;Clinic Pull List; ; 5/15/87 3:21 PM ;
;;2.0;Record Tracking;**7,37,43**;10/22/91
K RTDV,RTTDFL,RTPULL,RTDT,RTSORT,RTLIST D DIV^RTP4 G Q:'$D(RTDV) S X=$P(^DIC(195.1,+RTAPL,"INST",RTDV,0),"^",3),RTDVS=$S(X="c":2,X="a":3,X="h":4,X="d":5,1:1),RTX=X
S RTMES="PRINTED" D PULL^RTP6 K RTMES G Q:'$D(RTPULL) S:RTPULL RTSORT=$S(RTX="c":"C",RTX="a":"A",RTX="h":"H",RTX="d":"D",RTX="t":"T",1:"T") K:$E(RTPULL,1,3)="ALL" RTPULL
S RTRD(1)="Terminal Digits^sort by terminal digits",RTRD(2)="Clinic Name^sort by clinic name; then by terminal digits",RTRD(3)="Appointment Time^sort by clinic name; then by appointment time"
S RTRD(4)="Home Location^sort by home location; then terminal digits",RTRD(5)="Detailed Home Location^sort by home location, clinic, terminal digits"
S RTRD("B")=RTDVS,RTRD(0)="S",RTRD("A")="How do you want list sorted? " D SET^RTRD K RTRD G Q:$E(X)="^" S RTSORT=$E(X)
S RTRD(1)="All^include all appointments",RTRD(2)="Not Fillable^print a short non-fillable list" S:"HDCT"[RTSORT RTRD(3)="Detail-Not Fillable^print a detailed non-fillable list",RTRD(4)="Update^only include updates to list"
S RTRD(0)="S",RTRD("B")=1,RTRD("A")="Select type of list? " D SET^RTRD K RTRD G Q:$E(X)="^" S RTLIST=$E(X)
W ! S RTDESC="Clinic Pull List ["_$P($P(RTAPL,"^"),";",2)_"]",RTVAR="RTDV^RTSORT^RTAPL^RTDT^RTLIST"_$S($D(RTPULL):"^RTPULL^RTPULL0",1:""),RTPGM="START^RTP3" S IOP="HOME" D ^%ZIS K IOP D ZIS^RTUTL
I POP X "N POP D ^%ZISC D DEV^RTP32" G Q:POP
START U IO K ^TMP($J) D NOW^%DTC S RTRDT=%,RTBEG=RTDT-.0001 I RTLIST="D" D ^RTP32 W:'$D(RTNONE) !!?3,"No lists needed to be produced." G Q
I '$D(RTPULL) F RTDTE=RTBEG:0 S RTDTE=$O(^RTV(194.2,"C",RTDTE)) Q:RTDT<$P(RTDTE,".")!('RTDTE) F RTP=0:0 S RTP=$O(^RTV(194.2,"C",RTDTE,RTP)) Q:'RTP I $D(^RTV(194.2,RTP,0)) S X=^(0) I $P(X,"^",10)=1,$S(RTLIST="N":1,1:$P(X,"^",6)'="x") D PULL
I $D(RTPULL) S RTP=RTPULL D PULL
G ^RTP31
Q K RTC,RTDVS,RT,RT0,RTB,RTC,RTCLOC,RTCNME,RTDEV,RTDESC,RTDIGIT,RTDT,RTDTE,RTDV,RTESC,RTINST,RTL,RTLIST,RTLNME,RTP,RTP0,RTPAGE,RTPDT,RTPDV,RTPGM,RTVAR,RTPNME,RTPX,RTQ,RTQ0,Q,Q0,RTQDT,RTQNME,RTQST,RTQTIME,RTRDT,RTSORT,RTHLP,RTHL,RTHL1
K RTWND,RTTASK,RTNONE,RTHD,RTQST,RTBEG,RTPGFL,RTPULL0,RTTDFL,RTPULL,RTTD,RTTDX,RTVAR,RTWARD,RTYPE,RTHL,RTDIG,RTHLN,RTX,^TMP($J),RTDED,RTCM,RTJCOM,RTTRG,Y,RTHLOC,RTTDC,T,RTCUR1,RTCUR,P,C,DUOUT,X,RTBCNT,RTBREC,RTBREC1,RTBST D CLOSE^RTUTL Q
;
PULL ;Entry point for list with RTP
Q:'$D(^RTV(194.2,RTP,0)) S RTP0=^(0) I $P(RTP0,"^",15)=+RTAPL S RTPDV=+$P(RTP0,"^",12),RTPDT=+$P(RTP0,"^",2),RTB=+$P(RTP0,"^",5),Y=RTB D BOR^RTB S RTPNME=Y D RTQ
I "HDCT"[RTSORT,"AU"[RTLIST D NOW^%DTC S $P(^RTV(194.2,RTP,0),"^",$S(RTLIST="A":13,1:14))=%
Q
RTQ F RTQ=0:0 S RTQ=$O(^RTV(190.1,"AP",RTP,RTQ)) Q:'RTQ I $D(^RTV(190.1,RTQ,0)) S RTQ0=^(0) I $P(RTQ0,"^",5)=RTB S RTQST=$P(RTQ0,"^",6),RTQDT=+$P(RTQ0,"^",4) I $D(^RT(+RTQ0,0)) S RT=+RTQ0,RT0=^(0) D RT
Q
;
RT S RTBST=1 ;; CHANGE FOR RT*2.0*37
I $O(^RTV(195.9,RTB,"RECS",0)) D
.S (RTBST,RTBREC1,RTADMIN)="",RTBCNT=0,RTADMIN=$O(^DIC(195.2,"B","ADMINISTRATIVE FOLDER",RTADMIN))
.F RTBREC=0:0 S RTBREC=$O(^RTV(195.9,RTB,"RECS",RTBREC)) Q:'RTBREC S RTBCNT=RTBCNT+1,RTBREC1=$P(^RTV(195.9,RTB,"RECS",RTBREC,0),"^",1) S:$P(RT0,"^",3)=RTBREC1 RTBST=1
.S:RTBCNT=0 RTBST=0
.S:$P(RT0,"^",3)=RTADMIN RTBST=1
.S:$D(^DIC(195.1,"B","RADIOLOGY",+RTAPL)) RTBST=1
.K RTADMIN
Q:RTBST'=1 ;; END OF RT*2.0*37 CHANGE
S Y=0 I RTQST'="x",RTLIST="A" S Y=1
I RTQST'="x",RTLIST="U",'$P(RTQ0,"^",13) S Y=1
I RTQST="x",RTLIST="U",$P(RTQ0,"^",13) S Y=1
I RTQST="n",RTLIST="N" S Y=1
Q:'Y K RTINST S RTCLOC="",Y=$S($D(^RT(RT,"CL")):+$P(^("CL"),"^",5),1:0) D BOR^RTB S Y=RTCLOC
S RTHL=$S("HD"[RTSORT:$P(RT0,"^",6),1:"RTHL")
I RTHL="" S RTHL="AAA"
I (RTHL'="RTHL")&(RTHL'="AAA") S RTHLP=$P(^RTV(195.9,RTHL,0),"^",2),RTHL=$P(^SC(RTHLP,0),"^",1)
S P=$S(RTSORT="C"!(RTSORT="A")!(RTSORT="D"):$P(RTP0,"^"),1:"TDIGITS"),T=$S(RTSORT="A":$P(RTQ0,"^",4),1:"A"_RTCLOC)
I RTSORT'="A",$P(RT0,"^")[";DPT(",$D(^DPT(+RT0,0)) S T=$P(^(0),"^",9),T="A"_$E(T,8,9)_$E(T,6,7),RTTDFL=""
I RTDV=RTPDV S:$D(^TMP($J,"RTNEED",RTHL,P))["0" ^(P)=$S(P="TDIGITS":"",1:RTP0) S ^(P,T,RTQ)=RTQ0
BLD ;
K C I $D(^TMP($J,"RT",RT))=0 S C=0 F Q=0:0 S Q=$O(^RTV(190.1,"AC",RT,RTDT,Q)) Q:'Q I $D(^RTV(190.1,Q,0)) S Q0=^(0) I $P(Q0,"^",6)="r"!($P(Q0,"^",6)="n") S ^TMP($J,"RT",RT,$P(Q0,"^",4),Q)=Q0,C=C+1
S:$D(C) ^TMP($J,"RT",RT)=C Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTP3 4428 printed Apr 09, 2024@21:36:48 Page 2
RTP3 ;MJK/TROY ISC,JLU/TROY ISC;Clinic Pull List; ; 5/15/87 3:21 PM ;
+1 ;;2.0;Record Tracking;**7,37,43**;10/22/91
+2 KILL RTDV,RTTDFL,RTPULL,RTDT,RTSORT,RTLIST
DO DIV^RTP4
if '$DATA(RTDV)
GOTO Q
SET X=$PIECE(^DIC(195.1,+RTAPL,"INST",RTDV,0),"^",3)
SET RTDVS=$SELECT(X="c":2,X="a":3,X="h":4,X="d":5,1:1)
SET RTX=X
+3 SET RTMES="PRINTED"
DO PULL^RTP6
KILL RTMES
if '$DATA(RTPULL)
GOTO Q
if RTPULL
SET RTSORT=$SELECT(RTX="c":"C",RTX="a":"A",RTX="h":"H",RTX="d":"D",RTX="t":"T",1:"T")
if $EXTRACT(RTPULL,1,3)="ALL"
KILL RTPULL
+4 SET RTRD(1)="Terminal Digits^sort by terminal digits"
SET RTRD(2)="Clinic Name^sort by clinic name; then by terminal digits"
SET RTRD(3)="Appointment Time^sort by clinic name; then by appointment time"
+5 SET RTRD(4)="Home Location^sort by home location; then terminal digits"
SET RTRD(5)="Detailed Home Location^sort by home location, clinic, terminal digits"
+6 SET RTRD("B")=RTDVS
SET RTRD(0)="S"
SET RTRD("A")="How do you want list sorted? "
DO SET^RTRD
KILL RTRD
if $EXTRACT(X)="^"
GOTO Q
SET RTSORT=$EXTRACT(X)
+7 SET RTRD(1)="All^include all appointments"
SET RTRD(2)="Not Fillable^print a short non-fillable list"
if "HDCT"[RTSORT
SET RTRD(3)="Detail-Not Fillable^print a detailed non-fillable list"
SET RTRD(4)="Update^only include updates to list"
+8 SET RTRD(0)="S"
SET RTRD("B")=1
SET RTRD("A")="Select type of list? "
DO SET^RTRD
KILL RTRD
if $EXTRACT(X)="^"
GOTO Q
SET RTLIST=$EXTRACT(X)
+9 WRITE !
SET RTDESC="Clinic Pull List ["_$PIECE($PIECE(RTAPL,"^"),";",2)_"]"
SET RTVAR="RTDV^RTSORT^RTAPL^RTDT^RTLIST"_$SELECT($DATA(RTPULL):"^RTPULL^RTPULL0",1:"")
SET RTPGM="START^RTP3"
SET IOP="HOME"
DO ^%ZIS
KILL IOP
DO ZIS^RTUTL
+10 IF POP
XECUTE "N POP D ^%ZISC D DEV^RTP32"
if POP
GOTO Q
START USE IO
KILL ^TMP($JOB)
DO NOW^%DTC
SET RTRDT=%
SET RTBEG=RTDT-.0001
IF RTLIST="D"
DO ^RTP32
if '$DATA(RTNONE)
WRITE !!?3,"No lists needed to be produced."
GOTO Q
+1 IF '$DATA(RTPULL)
FOR RTDTE=RTBEG:0
SET RTDTE=$ORDER(^RTV(194.2,"C",RTDTE))
if RTDT<$PIECE(RTDTE,".")!('RTDTE)
QUIT
FOR RTP=0:0
SET RTP=$ORDER(^RTV(194.2,"C",RTDTE,RTP))
if 'RTP
QUIT
IF $DATA(^RTV(194.2,RTP,0))
SET X=^(0)
IF $PIECE(X,"^",10)=1
IF $SELECT(RTLIST="N":1,1:$PIECE(X,"^",6)'="x")
DO PULL
+2 IF $DATA(RTPULL)
SET RTP=RTPULL
DO PULL
+3 GOTO ^RTP31
Q KILL RTC,RTDVS,RT,RT0,RTB,RTC,RTCLOC,RTCNME,RTDEV,RTDESC,RTDIGIT,RTDT,RTDTE,RTDV,RTESC,RTINST,RTL,RTLIST,RTLNME,RTP,RTP0,RTPAGE,RTPDT,RTPDV,RTPGM,RTVAR,RTPNME,RTPX,RTQ,RTQ0,Q,Q0,RTQDT,RTQNME,RTQST,RTQTIME,RTRDT,RTSORT,RTHLP,RTHL,RTHL1
+1 KILL RTWND,RTTASK,RTNONE,RTHD,RTQST,RTBEG,RTPGFL,RTPULL0,RTTDFL,RTPULL,RTTD,RTTDX,RTVAR,RTWARD,RTYPE,RTHL,RTDIG,RTHLN,RTX,^TMP($JOB),RTDED,RTCM,RTJCOM,RTTRG,Y,RTHLOC,RTTDC,T,RTCUR1,RTCUR,P,C,DUOUT,X,RTBCNT,RTBREC,RTBREC1,RTBST
DO CLOSE^RTUTL
QUIT
+2 ;
PULL ;Entry point for list with RTP
+1 if '$DATA(^RTV(194.2,RTP,0))
QUIT
SET RTP0=^(0)
IF $PIECE(RTP0,"^",15)=+RTAPL
SET RTPDV=+$PIECE(RTP0,"^",12)
SET RTPDT=+$PIECE(RTP0,"^",2)
SET RTB=+$PIECE(RTP0,"^",5)
SET Y=RTB
DO BOR^RTB
SET RTPNME=Y
DO RTQ
+2 IF "HDCT"[RTSORT
IF "AU"[RTLIST
DO NOW^%DTC
SET $PIECE(^RTV(194.2,RTP,0),"^",$SELECT(RTLIST="A":13,1:14))=%
+3 QUIT
RTQ FOR RTQ=0:0
SET RTQ=$ORDER(^RTV(190.1,"AP",RTP,RTQ))
if 'RTQ
QUIT
IF $DATA(^RTV(190.1,RTQ,0))
SET RTQ0=^(0)
IF $PIECE(RTQ0,"^",5)=RTB
SET RTQST=$PIECE(RTQ0,"^",6)
SET RTQDT=+$PIECE(RTQ0,"^",4)
IF $DATA(^RT(+RTQ0,0))
SET RT=+RTQ0
SET RT0=^(0)
DO RT
+1 QUIT
+2 ;
RT ;; CHANGE FOR RT*2.0*37
SET RTBST=1
+1 IF $ORDER(^RTV(195.9,RTB,"RECS",0))
Begin DoDot:1
+2 SET (RTBST,RTBREC1,RTADMIN)=""
SET RTBCNT=0
SET RTADMIN=$ORDER(^DIC(195.2,"B","ADMINISTRATIVE FOLDER",RTADMIN))
+3 FOR RTBREC=0:0
SET RTBREC=$ORDER(^RTV(195.9,RTB,"RECS",RTBREC))
if 'RTBREC
QUIT
SET RTBCNT=RTBCNT+1
SET RTBREC1=$PIECE(^RTV(195.9,RTB,"RECS",RTBREC,0),"^",1)
if $PIECE(RT0,"^",3)=RTBREC1
SET RTBST=1
+4 if RTBCNT=0
SET RTBST=0
+5 if $PIECE(RT0,"^",3)=RTADMIN
SET RTBST=1
+6 if $DATA(^DIC(195.1,"B","RADIOLOGY",+RTAPL))
SET RTBST=1
+7 KILL RTADMIN
End DoDot:1
+8 ;; END OF RT*2.0*37 CHANGE
if RTBST'=1
QUIT
+9 SET Y=0
IF RTQST'="x"
IF RTLIST="A"
SET Y=1
+10 IF RTQST'="x"
IF RTLIST="U"
IF '$PIECE(RTQ0,"^",13)
SET Y=1
+11 IF RTQST="x"
IF RTLIST="U"
IF $PIECE(RTQ0,"^",13)
SET Y=1
+12 IF RTQST="n"
IF RTLIST="N"
SET Y=1
+13 if 'Y
QUIT
KILL RTINST
SET RTCLOC=""
SET Y=$SELECT($DATA(^RT(RT,"CL")):+$PIECE(^("CL"),"^",5),1:0)
DO BOR^RTB
SET Y=RTCLOC
+14 SET RTHL=$SELECT("HD"[RTSORT:$PIECE(RT0,"^",6),1:"RTHL")
+15 IF RTHL=""
SET RTHL="AAA"
+16 IF (RTHL'="RTHL")&(RTHL'="AAA")
SET RTHLP=$PIECE(^RTV(195.9,RTHL,0),"^",2)
SET RTHL=$PIECE(^SC(RTHLP,0),"^",1)
+17 SET P=$SELECT(RTSORT="C"!(RTSORT="A")!(RTSORT="D"):$PIECE(RTP0,"^"),1:"TDIGITS")
SET T=$SELECT(RTSORT="A":$PIECE(RTQ0,"^",4),1:"A"_RTCLOC)
+18 IF RTSORT'="A"
IF $PIECE(RT0,"^")[";DPT("
IF $DATA(^DPT(+RT0,0))
SET T=$PIECE(^(0),"^",9)
SET T="A"_$EXTRACT(T,8,9)_$EXTRACT(T,6,7)
SET RTTDFL=""
+19 IF RTDV=RTPDV
if $DATA(^TMP($JOB,"RTNEED",RTHL,P))["0"
SET ^(P)=$SELECT(P="TDIGITS":"",1:RTP0)
SET ^(P,T,RTQ)=RTQ0
BLD ;
+1 KILL C
IF $DATA(^TMP($JOB,"RT",RT))=0
SET C=0
FOR Q=0:0
SET Q=$ORDER(^RTV(190.1,"AC",RT,RTDT,Q))
if 'Q
QUIT
IF $DATA(^RTV(190.1,Q,0))
SET Q0=^(0)
IF $PIECE(Q0,"^",6)="r"!($PIECE(Q0,"^",6)="n")
SET ^TMP($JOB,"RT",RT,$PIECE(Q0,"^",4),Q)=Q0
SET C=C+1
+2 if $DATA(C)
SET ^TMP($JOB,"RT",RT)=C
QUIT
+3 ;
