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