- RTP41 ;MJK/TROY ISC;Charge Out Pull List (continued); ; 4/24/87 11:55 AM ;
- ;;v 2.0;Record Tracking;;10/22/91
- ;
- LIST W !!!,$S(RTLIST="RTCANCEL":"Cancelled Requests",1:"Missing Records")," List" D NOW^%DTC S Y=$E(%,1,12) D D^DIQ W ?55,"RUN DATE: ",Y
- W !!,"PULL LIST",?25,"REQUEST#",?35,"REQUESTED TIME",?60,"RECORD INFORMATION" D EQUALS^RTUTL3
- S RTPX="" F RTPX1=0:0 S RTPX=$O(^TMP($J,RTLIST,RTPX)) Q:RTPX="" F RTQ=0:0 S RTQ=$O(^TMP($J,RTLIST,RTPX,RTQ)) Q:'RTQ S RTQ0=^(RTQ) D WRITE
- K RTPX,RTPX1,RTQ,RTQ0 Q
- ;
- WRITE S RT=+RTQ0 Q:'$D(^RT(+RT,0)) S RT0=^(0),RTYPE=$S($D(^DIC(195.2,+$P(RT0,"^",3),0)):$P(^(0),"^",2),1:"???")_+$P(RT0,"^",7),Y=+$P(RTQ0,"^",4) D D^DIQ S RTQDT=Y,Y=$P(RT0,"^") D NAME^RTB S RTNME=Y
- S RTSSN="" I $P(RT0,"^")[";DPT(",$D(^DPT(+RT0,0)) S X=$P(^(0),"^",9),RTSSN=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10)
- W !?2,$E(RTPX,1,20),?25,RTQ,?35,RTQDT,?60,RTYPE,?65,$E(RTNME,1,15),!,?60,RT,?65,RTSSN D LINE^RTUTL3
- K RT,RT0,RTNME,RTQDT,RTYPE Q
- ;
- SHOW ;
- W !!,"The following CLINIC pull lists will be ",RTMES,": " S RTEND=RTDT_".9999",RTC=0
- F D=(RTDT-.0001):0 S D=$O(^RTV(194.2,"C",D)) Q:'D!(D>RTEND) F P=0:0 S P=$O(^RTV(194.2,"C",D,P)) Q:'P I $D(^RTV(194.2,P,0)) S X=^(0) I $P(X,"^",10)=1,$P(X,"^",15)=+RTAPL,$P(X,"^",6)'="x",$P(X,"^",12) S RTC=RTC+1 D SHOW1
- I 'RTC W !?5,*7,"No CLINIC pull lists need to be ",RTMES,"."
- K RTEND,P,D Q
- ;
- SHOW1 S SAVX=X I RTC#10=0 S DIR(0)="E" D ^DIR I X="^" S D=9999999 Q
- S X=SAVX W !?5,RTC,". ",$E($P($P(X,"^"),"["),1,25),?35," Status: " S C=$P(^DD(194.2,6,0),"^",2),Y=$P(X,"^",6) D Y^DIQ W Y Q
- ;
- BOR ;ask record retirement borrower
- ;return rtb, rtyes, rtaccn
- S A=+RTAPL,DIC("B")=$S($D(^DIC(195.1,+RTAPL,4)):$P(^(4),"^",4),1:"")
- D DIC^RTDPA31 S DIC="^RTV(195.9,",DIC("A")="Select Record Retirement Borrower: ",DIC(0)="IAEMQ",DIC("S")="S Z0=^(0),Z=$P($P(Z0,U),"";"",2) I Z=""DIC(4,"",$P(Z0,U,3)="_+RTAPL_" D DICS1^RTDPA31" W ! D ^DIC Q:Y<0 S RTB=+Y
- ;
- W ! S DIR(0)="YO",DIR("B")="Yes" D H13 S DIR("A")="Do you want to create "_$S($T:"'"_Y_"'",1:"Perpetual")_" records from Pull list",DIR("?")="^D H1^RTP41",DIR("??")="^D H12^RTP41" D ^DIR K DIR S RTYES=Y
- Q:'RTYES
- I RTYES D H13 I '$T D H14 H 3 S RTYES="^"
- ;
- W ! S DIR(0)="FO^3:20",DIR("A")="Enter the Record Center's accession number for these records",DIR("?")="^D H4^RTP41",DIR("??")="^D H42^RTP41" D ^DIR K DIR S RTACCN=Y
- Q
- ;
- H1 W !!?5,"Answer 'Yes' to create the default perpetual record."
- W !?5,"Answer 'No' to just charge out the retirement pull list." Q
- H12 W !!?5,"After the Pull list(s) are charged out, a perpetual record"
- W !?5,"can be created for each patient on the Pull list."
- D H13 I $T W !?5,"'",Y,"' records and labels will be created" Q
- H14 W !?5,"The application default perpetual record is NOT defined."
- W !?14,"NO records will be created" Q
- H13 I $D(^DIC(195.1,+RTAPL,4)),$P(^(4),"^",5) S Y=$P(^(4),"^",5),C=$P(^DD(195.1,45,0),"^",2) D Y^DIQ IF 1
- Q
- H4 W !!?5,"The accession number will be recorded in the content descriptor"
- W !?5,"field of the perpetual records created from these pull lists." Q
- H42 W !!?5,"Enter the accession number as provided by the Record Center."
- W !?20,"from 3-20 characters"
- W !!?5,"The accession numbers will be used in the future to locate"
- W !?5,"records transfered to the Record Center." Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTP41 3319 printed Jan 18, 2025@03:35:29 Page 2
- RTP41 ;MJK/TROY ISC;Charge Out Pull List (continued); ; 4/24/87 11:55 AM ;
- +1 ;;v 2.0;Record Tracking;;10/22/91
- +2 ;
- LIST WRITE !!!,$SELECT(RTLIST="RTCANCEL":"Cancelled Requests",1:"Missing Records")," List"
- DO NOW^%DTC
- SET Y=$EXTRACT(%,1,12)
- DO D^DIQ
- WRITE ?55,"RUN DATE: ",Y
- +1 WRITE !!,"PULL LIST",?25,"REQUEST#",?35,"REQUESTED TIME",?60,"RECORD INFORMATION"
- DO EQUALS^RTUTL3
- +2 SET RTPX=""
- FOR RTPX1=0:0
- SET RTPX=$ORDER(^TMP($JOB,RTLIST,RTPX))
- if RTPX=""
- QUIT
- FOR RTQ=0:0
- SET RTQ=$ORDER(^TMP($JOB,RTLIST,RTPX,RTQ))
- if 'RTQ
- QUIT
- SET RTQ0=^(RTQ)
- DO WRITE
- +3 KILL RTPX,RTPX1,RTQ,RTQ0
- QUIT
- +4 ;
- WRITE SET RT=+RTQ0
- if '$DATA(^RT(+RT,0))
- QUIT
- SET RT0=^(0)
- SET RTYPE=$SELECT($DATA(^DIC(195.2,+$PIECE(RT0,"^",3),0)):$PIECE(^(0),"^",2),1:"???")_+$PIECE(RT0,"^",7)
- SET Y=+$PIECE(RTQ0,"^",4)
- DO D^DIQ
- SET RTQDT=Y
- SET Y=$PIECE(RT0,"^")
- DO NAME^RTB
- SET RTNME=Y
- +1 SET RTSSN=""
- IF $PIECE(RT0,"^")[";DPT("
- IF $DATA(^DPT(+RT0,0))
- SET X=$PIECE(^(0),"^",9)
- SET RTSSN=$EXTRACT(X,1,3)_"-"_$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,10)
- +2 WRITE !?2,$EXTRACT(RTPX,1,20),?25,RTQ,?35,RTQDT,?60,RTYPE,?65,$EXTRACT(RTNME,1,15),!,?60,RT,?65,RTSSN
- DO LINE^RTUTL3
- +3 KILL RT,RT0,RTNME,RTQDT,RTYPE
- QUIT
- +4 ;
- SHOW ;
- +1 WRITE !!,"The following CLINIC pull lists will be ",RTMES,": "
- SET RTEND=RTDT_".9999"
- SET RTC=0
- +2 FOR D=(RTDT-.0001):0
- SET D=$ORDER(^RTV(194.2,"C",D))
- if 'D!(D>RTEND)
- QUIT
- FOR P=0:0
- SET P=$ORDER(^RTV(194.2,"C",D,P))
- if 'P
- QUIT
- IF $DATA(^RTV(194.2,P,0))
- SET X=^(0)
- IF $PIECE(X,"^",10)=1
- IF $PIECE(X,"^",15)=+RTAPL
- IF $PIECE(X,"^",6)'="x"
- IF $PIECE(X,"^",12)
- SET RTC=RTC+1
- DO SHOW1
- +3 IF 'RTC
- WRITE !?5,*7,"No CLINIC pull lists need to be ",RTMES,"."
- +4 KILL RTEND,P,D
- QUIT
- +5 ;
- SHOW1 SET SAVX=X
- IF RTC#10=0
- SET DIR(0)="E"
- DO ^DIR
- IF X="^"
- SET D=9999999
- QUIT
- +1 SET X=SAVX
- WRITE !?5,RTC,". ",$EXTRACT($PIECE($PIECE(X,"^"),"["),1,25),?35," Status: "
- SET C=$PIECE(^DD(194.2,6,0),"^",2)
- SET Y=$PIECE(X,"^",6)
- DO Y^DIQ
- WRITE Y
- QUIT
- +2 ;
- BOR ;ask record retirement borrower
- +1 ;return rtb, rtyes, rtaccn
- +2 SET A=+RTAPL
- SET DIC("B")=$SELECT($DATA(^DIC(195.1,+RTAPL,4)):$PIECE(^(4),"^",4),1:"")
- +3 DO DIC^RTDPA31
- SET DIC="^RTV(195.9,"
- SET DIC("A")="Select Record Retirement Borrower: "
- SET DIC(0)="IAEMQ"
- SET DIC("S")="S Z0=^(0),Z=$P($P(Z0,U),"";"",2) I Z=""DIC(4,"",$P(Z0,U,3)="_+RTAPL_" D DICS1^RTDPA31"
- WRITE !
- DO ^DIC
- if Y<0
- QUIT
- SET RTB=+Y
- +4 ;
- +5 WRITE !
- SET DIR(0)="YO"
- SET DIR("B")="Yes"
- DO H13
- SET DIR("A")="Do you want to create "_$SELECT($TEST:"'"_Y_"'",1:"Perpetual")_" records from Pull list"
- SET DIR("?")="^D H1^RTP41"
- SET DIR("??")="^D H12^RTP41"
- DO ^DIR
- KILL DIR
- SET RTYES=Y
- +6 if 'RTYES
- QUIT
- +7 IF RTYES
- DO H13
- IF '$TEST
- DO H14
- HANG 3
- SET RTYES="^"
- +8 ;
- +9 WRITE !
- SET DIR(0)="FO^3:20"
- SET DIR("A")="Enter the Record Center's accession number for these records"
- SET DIR("?")="^D H4^RTP41"
- SET DIR("??")="^D H42^RTP41"
- DO ^DIR
- KILL DIR
- SET RTACCN=Y
- +10 QUIT
- +11 ;
- H1 WRITE !!?5,"Answer 'Yes' to create the default perpetual record."
- +1 WRITE !?5,"Answer 'No' to just charge out the retirement pull list."
- QUIT
- H12 WRITE !!?5,"After the Pull list(s) are charged out, a perpetual record"
- +1 WRITE !?5,"can be created for each patient on the Pull list."
- +2 DO H13
- IF $TEST
- WRITE !?5,"'",Y,"' records and labels will be created"
- QUIT
- H14 WRITE !?5,"The application default perpetual record is NOT defined."
- +1 WRITE !?14,"NO records will be created"
- QUIT
- H13 IF $DATA(^DIC(195.1,+RTAPL,4))
- IF $PIECE(^(4),"^",5)
- SET Y=$PIECE(^(4),"^",5)
- SET C=$PIECE(^DD(195.1,45,0),"^",2)
- DO Y^DIQ
- IF 1
- +1 QUIT
- H4 WRITE !!?5,"The accession number will be recorded in the content descriptor"
- +1 WRITE !?5,"field of the perpetual records created from these pull lists."
- QUIT
- H42 WRITE !!?5,"Enter the accession number as provided by the Record Center."
- +1 WRITE !?20,"from 3-20 characters"
- +2 WRITE !!?5,"The accession numbers will be used in the future to locate"
- +3 WRITE !?5,"records transfered to the Record Center."
- QUIT