RTP5 ;MJK/TROY ISC;Clinic Pull List for Other Institution; ; 5/7/87 12:36 PM ;
;;v 2.0;Record Tracking;;10/22/91
S Y=+$O(^DIC(195.1,+RTAPL,"INST",0)) I '$O(^(Y)) W !!?5,*7,"...this application only has one institution defined." G Q
K RTDV,RTDT S RTHD="HD^RTP5",RTPAGE=0 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,1:1)
S RTRD(1)="Send only^list records to be 'sent' to other institutions",RTRD(2)="Receive only^list records to be 'received' from other institutions",RTRD(3)="Both^print both the 'send' and 'receive' lists",RTRD("B")=3,RTRD(0)="S"
S RTRD("A")="Which list do you want to print? " D SET^RTRD K RTRD S X=$E(X) G Q:X="^" S:X="B" X="SR" S RTLIST=X
RTDT W ! S %DT="EAFX",%DT("A")="Select Date: " D ^%DT K %DT G Q:Y<0 I Y>0 S RTDT=Y,RTMES="SEARCHED" D SHOW^RTP41 K RTMES I 'RTC K RTDT G RTDT
W ! S RTDESC="Clinic Pull List(other institution) ["_$P($P(RTAPL,"^"),";",2)_"]",RTVAR="RTDV^RTAPL^RTDT^RTLIST^RTPAGE",RTPGM="START^RTP5" D ZIS^RTUTL G Q:POP
;
START U IO K ^TMP($J) D NOW^%DTC S RTRDT=%,RTBEG=RTDT-.0001,RTSORT=""
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
F RTLIST1="S","R" I RTLIST[RTLIST1 S RTAUX=$S(RTLIST1="S":"RTSEND",1:"RTRECV") D NOT:'$D(^TMP($J,RTAUX)) G Q:$D(RTESC) I $D(RTLIST1) F RTDIVZ=0:0 S RTDIVZ=$O(^TMP($J,RTAUX,RTDIVZ)) Q:'RTDIVZ D HD,DIGIT G Q:$D(RTESC)
Q K RTSORT,RT,RT0,RTAUX,RTB,RTBEG,RTC,RTCDV,RTDESC,RTDIGIT,RTDIVZ,RTDT,RTDTE,RTDV,RTDVS,RTESC,RTHD,RTINST,RTL,RTLIST,RTLIST1,RTLNME,RTP,RTP0,RTPAGE,RTPDT,RTPDV,RTPGM,RTPNME,RTQ,RTQ0,RTQDT,RTQST,RTRDT,RTTDX,RTVAR,Y
K RTCLOC,RTCNME,RTDEV,RTQNME,RTQTIME,RTTD,RTYPE,^TMP($J) D CLOSE^RTUTL Q
;
;
DIGIT W !!?5,"[",$S(RTLIST1="S":"SEND",1:"RECEIVE")," these records ",$S(RTLIST1="S":"to",1:"from")," '",$S($D(^DIC(4,RTDIVZ,0)):$P(^(0),"^"),1:"UNKNOWN"),"']",!
S (RTLNME,RTCNME,RTL,RTDIGIT)="" F RTTDX=0:0 S RTDIGIT=$O(^TMP($J,RTAUX,RTDIVZ,RTDIGIT)) Q:RTDIGIT="" D RTQ Q:$D(RTESC)
Q
;
RTQ F RTQ=0:0 S RTQ=$O(^TMP($J,RTAUX,RTDIVZ,RTDIGIT,RTQ)) Q:'RTQ S RTQ0=^(RTQ),RT=+RTQ0,RT0=^RT(RT,0) D PRT^RTP51 G RTQQ:$D(RTESC)
RTQQ Q
;
NOT D HD Q:$D(RTESC) W !!?5,"...no records need to be '",$S(RTLIST1="S":"SENT TO",1:"RECEIVED FROM"),"' other institutions." Q
;
PULL 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 RTQX
Q
;
RTQX 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 K RTINST,RTCDV S X=$S($D(^RT(RT,"CL")):$P(^("CL"),"^",5),1:""),A=+RTAPL D INST1^RTUTL:X Q:'$D(RTINST) S RTCDV=RTINST K RTINST
S T=9999 I $P(RT0,"^")[";DPT(",$D(^DPT(+RT0,0)) S T=$P(^(0),"^",9),T="A"_$E(T,8,9)_$E(T,6,7)
I RTDV'=RTPDV,RTDV=RTCDV S ^TMP($J,"RTSEND",RTPDV,T,RTQ)=RTQ0
I RTDV=RTPDV,RTDV'=RTCDV S ^TMP($J,"RTRECV",RTCDV,T,RTQ)=RTQ0
D BLD^RTP3 Q
;
HD ;
K RTESC I RTPAGE,$E(IOST,1,2)="C-" D ESC^RTRD Q:$D(RTESC)
S RTPAGE=RTPAGE+1,Y=RTRDT D D^DIQ
W @IOF,!,"Special Multi-Institution Record Pull List",$S(RTLIST1="S":" [SEND ONLY]",1:" [RECEIVE ONLY]")," - ",$P($P(RTAPL,"^"),";",2),?103,"Page : ",RTPAGE,!,"[Institution : ",$P(^DIC(4,RTDV,0),"^"),"]",?103,"Run Date: ",Y
W !,"[Sorted by: Terminal Digits]" S Y=RTDT D D^DIQ W ?97,"Requested Date: ",Y
W !!?5,"Name",?27,"Type",?33,"Request#",?42,"Status",?55,"Requestor",?72,"Time",?82,"Current Location",?105,"Other Requests for Record:" D LINE^RTUTL3
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTP5 3760 printed Apr 09, 2024@21:36:58 Page 2
RTP5 ;MJK/TROY ISC;Clinic Pull List for Other Institution; ; 5/7/87 12:36 PM ;
+1 ;;v 2.0;Record Tracking;;10/22/91
+2 SET Y=+$ORDER(^DIC(195.1,+RTAPL,"INST",0))
IF '$ORDER(^(Y))
WRITE !!?5,*7,"...this application only has one institution defined."
GOTO Q
+3 KILL RTDV,RTDT
SET RTHD="HD^RTP5"
SET RTPAGE=0
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,1:1)
+4 SET RTRD(1)="Send only^list records to be 'sent' to other institutions"
SET RTRD(2)="Receive only^list records to be 'received' from other institutions"
SET RTRD(3)="Both^print both the 'send' and 'receive' lists"
SET RTRD("B")=3
SET RTRD(0)="S"
+5 SET RTRD("A")="Which list do you want to print? "
DO SET^RTRD
KILL RTRD
SET X=$EXTRACT(X)
if X="^"
GOTO Q
if X="B"
SET X="SR"
SET RTLIST=X
RTDT WRITE !
SET %DT="EAFX"
SET %DT("A")="Select Date: "
DO ^%DT
KILL %DT
if Y<0
GOTO Q
IF Y>0
SET RTDT=Y
SET RTMES="SEARCHED"
DO SHOW^RTP41
KILL RTMES
IF 'RTC
KILL RTDT
GOTO RTDT
+1 WRITE !
SET RTDESC="Clinic Pull List(other institution) ["_$PIECE($PIECE(RTAPL,"^"),";",2)_"]"
SET RTVAR="RTDV^RTAPL^RTDT^RTLIST^RTPAGE"
SET RTPGM="START^RTP5"
DO ZIS^RTUTL
if POP
GOTO Q
+2 ;
START USE IO
KILL ^TMP($JOB)
DO NOW^%DTC
SET RTRDT=%
SET RTBEG=RTDT-.0001
SET RTSORT=""
+1 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 FOR RTLIST1="S","R"
IF RTLIST[RTLIST1
SET RTAUX=$SELECT(RTLIST1="S":"RTSEND",1:"RTRECV")
if '$DATA(^TMP($JOB,RTAUX))
DO NOT
if $DATA(RTESC)
GOTO Q
IF $DATA(RTLIST1)
FOR RTDIVZ=0:0
SET RTDIVZ=$ORDER(^TMP($JOB,RTAUX,RTDIVZ))
if 'RTDIVZ
QUIT
DO HD
DO DIGIT
if $DATA(RTESC)
GOTO Q
Q KILL RTSORT,RT,RT0,RTAUX,RTB,RTBEG,RTC,RTCDV,RTDESC,RTDIGIT,RTDIVZ,RTDT,RTDTE,RTDV,RTDVS,RTESC,RTHD,RTINST,RTL,RTLIST,RTLIST1,RTLNME,RTP,RTP0,RTPAGE,RTPDT,RTPDV,RTPGM,RTPNME,RTQ,RTQ0,RTQDT,RTQST,RTRDT,RTTDX,RTVAR,Y
+1 KILL RTCLOC,RTCNME,RTDEV,RTQNME,RTQTIME,RTTD,RTYPE,^TMP($JOB)
DO CLOSE^RTUTL
QUIT
+2 ;
+3 ;
DIGIT WRITE !!?5,"[",$SELECT(RTLIST1="S":"SEND",1:"RECEIVE")," these records ",$SELECT(RTLIST1="S":"to",1:"from")," '",$SELECT($DATA(^DIC(4,RTDIVZ,0)):$PIECE(^(0),"^"),1:"UNKNOWN"),"']",!
+1 SET (RTLNME,RTCNME,RTL,RTDIGIT)=""
FOR RTTDX=0:0
SET RTDIGIT=$ORDER(^TMP($JOB,RTAUX,RTDIVZ,RTDIGIT))
if RTDIGIT=""
QUIT
DO RTQ
if $DATA(RTESC)
QUIT
+2 QUIT
+3 ;
RTQ FOR RTQ=0:0
SET RTQ=$ORDER(^TMP($JOB,RTAUX,RTDIVZ,RTDIGIT,RTQ))
if 'RTQ
QUIT
SET RTQ0=^(RTQ)
SET RT=+RTQ0
SET RT0=^RT(RT,0)
DO PRT^RTP51
if $DATA(RTESC)
GOTO RTQQ
RTQQ QUIT
+1 ;
NOT DO HD
if $DATA(RTESC)
QUIT
WRITE !!?5,"...no records need to be '",$SELECT(RTLIST1="S":"SENT TO",1:"RECEIVED FROM"),"' other institutions."
QUIT
+1 ;
PULL 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 RTQX
+1 QUIT
+2 ;
RTQX 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 KILL RTINST,RTCDV
SET X=$SELECT($DATA(^RT(RT,"CL")):$PIECE(^("CL"),"^",5),1:"")
SET A=+RTAPL
if X
DO INST1^RTUTL
if '$DATA(RTINST)
QUIT
SET RTCDV=RTINST
KILL RTINST
+1 SET T=9999
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)
+2 IF RTDV'=RTPDV
IF RTDV=RTCDV
SET ^TMP($JOB,"RTSEND",RTPDV,T,RTQ)=RTQ0
+3 IF RTDV=RTPDV
IF RTDV'=RTCDV
SET ^TMP($JOB,"RTRECV",RTCDV,T,RTQ)=RTQ0
+4 DO BLD^RTP3
QUIT
+5 ;
HD ;
+1 KILL RTESC
IF RTPAGE
IF $EXTRACT(IOST,1,2)="C-"
DO ESC^RTRD
if $DATA(RTESC)
QUIT
+2 SET RTPAGE=RTPAGE+1
SET Y=RTRDT
DO D^DIQ
+3 WRITE @IOF,!,"Special Multi-Institution Record Pull List",$SELECT(RTLIST1="S":" [SEND ONLY]",1:" [RECEIVE ONLY]")," - ",$PIECE($PIECE(RTAPL,"^"),";",2),?103,"Page : ",RTPAGE,!,"[Institution : ",$PIECE(^DIC(4,RTDV,0),"^"),"]",?103,"Run Date:
",Y
+4 WRITE !,"[Sorted by: Terminal Digits]"
SET Y=RTDT
DO D^DIQ
WRITE ?97,"Requested Date: ",Y
+5 WRITE !!?5,"Name",?27,"Type",?33,"Request#",?42,"Status",?55,"Requestor",?72,"Time",?82,"Current Location",?105,"Other Requests for Record:"
DO LINE^RTUTL3
+6 QUIT
+7 ;
