- RTP ;MJK/TROY ISC;Pull List Option; ; 5/7/87 12:37 PM ;
- ;;v 2.0;Record Tracking;;10/22/91
- D DT^DICRW S X=$T(+1),DIK="^DOPT("""_$P(X," ;",1)_""","
- G:$D(^DOPT($P(X," ;"),11)) A S ^DOPT($P(X," ;"),0)=$P(X,";",3)_"^1N^" F I=1:1 S Y=$T(@I) Q:Y="" S ^DOPT($P(X," ;"),I,0)=$P(Y,";",3,99)
- D IXALL^DIK
- A D OVERALL^RTPSET Q:$D(XQUIT)
- W !! S DIC="^DOPT("""_$P($T(+1)," ;")_""",",DIC(0)="IQEAM" D ^DIC Q:Y<0 D @+Y G A
- ;
- 1 ;;Create Pull List
- CREATE I '$D(RTDIV) D DIV1^RTPSET I '$D(RTDIV) D MES^RTP4 Q
- W ! S DIC("A")="Enter NEW PULL LIST NAME: ",DIC(0)="IAELQ",DIC("S")="I 0",DIC("DR")="15////"_+RTAPL,DIC="^RTV(194.2,",DLAYGO=194.2 D ^DIC K DIC G Q:Y<0
- K RTQDT,RTB,RTINST,RTSEL S RTPLTY=2,RTSHOW="",DIE("NO^")="OUTOK",(DA,RTPULL)=+Y,DR="[RT PULL LIST]",DIE="^RTV(194.2," D ^DIE K RTSHOW,RTINST,RTPLTY,DIE,DE,DQ
- I $D(Y) W !?3,*7,"...entry is incomplete" S DIK="^RTV(194.2," D ^DIK K DIK W "...pull list has been deleted." S Y=""
- D ADD^RTP2:'$D(Y) K DLAYGO,DIC,RTESC,RTPULL
- Q K X1,A,DA,D0,DR,DIE,P,POP,RTC,RTY,%,%I,%H
- K DIC,X,Y,J,I Q
- ;
- 2 ;;Change Pull List Date
- W ! S DIC("S")="I $P(^(0),U,6)=""r"",'$P(^(0),U,13),$P(^(0),U,15)=+RTAPL",DIC(0)="IAEMQ",DIC="^RTV(194.2," D ^DIC K DIC Q:Y<0 S RTPULL=+Y
- S %DT="ATEFX",%DT("A")="Enter NEW Date: ",%DT(0)="NOW" D ^%DT K %DT G Q2:Y<0 S RTQDT=Y
- S RTRD(1)="Yes^change the date",RTRD(2)="No^do not change the date",RTRD(0)="S",RTRD("B")=2,RTRD("A")="Are you sure you want to change the date the records are needed? " D SET^RTRD K RTRD G Q2:$E(X)'="Y"
- 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" W "." S DA=RTQ,DR="4////"_RTQDT S DIE="^RTV(190.1," D ^DIE K DE,DQ
- S DA=RTPULL,DR="2////"_RTQDT,DIE="^RTV(194.2," D ^DIE
- Q2 K DE,DQ,RTPULL,RTQDT,RTQ G Q
- ;
- 3 ;;Add Records Request to List
- I '$D(RTDIV) D DIV1^RTPSET I '$D(RTDIV) D MES^RTP4 Q
- D LIST G Q:Y<0 D ADD^RTP2 K DIC,RTESC,RTPULL G Q
- ;
- 4 ;;Cancel an Entire Pull List
- D LIST G Q4:Y<0 S Y="cancel" D ASK G Q4:$E(X)'="Y" S RTSTAT="x"
- CAN 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"!($P(^(0),"^",6)="n") S DA=RTQ,DIE="^RTV(190.1,",DR="[RT CHANGE REQUEST STATUS]" D ^DIE K DE,DQ
- K RTQ D STAT W !!?3,"...pull list has been cancelled"
- Q4 K RTPULL,RTSTAT
- K DUOUT,X,Y,DIC,J G Q
- ;
- 5 ;;Designate Requests as Not Fillable
- G 5^RTP1
- ;
- 6 ;;Charge Out Pull List
- G ^RTP4
- ;
- 7 ;;Flag Pull List as PULLED/NOT CHARGED
- ;D LIST Q:Y<0 S RTSTAT="p" G CAN
- Q
- ;
- 8 ;;Cancel Individual Requests from Pull List
- G 8^RTP1
- ;
- 9 ;;Modify Pull List Comments
- G 9^RTP1
- ;
- 10 ;;Pull List Print
- G ^RTP3
- ;
- 11 ;;Special Multi-Institution Prints
- G ^RTP5
- ;
- 12 ;;Cancel an Entire Pull list for all future dates
- G ALL^RTPCAN
- ;
- LIST W ! S DIC("S")="I $P(^(0),U,2)'<DT,$P(^(0),U,6)=""r"",$P(^(0),U,15)=+RTAPL",DIC(0)="IAEMQ",DIC="^RTV(194.2," D ^DIC K DIC Q:Y<0 S RTPULL=+Y Q
- ;
- STAT S DA=RTPULL,DR="[RT CHANGE PULL LIST STATUS]",DIE="^RTV(194.2," D ^DIE K DE,DQ Q
- ;
- ASK ;
- S RTRD(1)="Yes^"_Y_" entire pull list",RTRD(2)="No^not "_Y_" pull list",RTRD("B")=2,RTRD("A")="Are you sure you want to "_Y_" this pull list? ",RTRD(0)="S" D SET^RTRD K RTRD Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTP 3207 printed Jan 18, 2025@03:35:20 Page 2
- RTP ;MJK/TROY ISC;Pull List Option; ; 5/7/87 12:37 PM ;
- +1 ;;v 2.0;Record Tracking;;10/22/91
- +2 DO DT^DICRW
- SET X=$TEXT(+1)
- SET DIK="^DOPT("""_$PIECE(X," ;",1)_""","
- +3 if $DATA(^DOPT($PIECE(X," ;"),11))
- GOTO A
- SET ^DOPT($PIECE(X," ;"),0)=$PIECE(X,";",3)_"^1N^"
- FOR I=1:1
- SET Y=$TEXT(@I)
- if Y=""
- QUIT
- SET ^DOPT($PIECE(X," ;"),I,0)=$PIECE(Y,";",3,99)
- +4 DO IXALL^DIK
- A DO OVERALL^RTPSET
- if $DATA(XQUIT)
- QUIT
- +1 WRITE !!
- SET DIC="^DOPT("""_$PIECE($TEXT(+1)," ;")_""","
- SET DIC(0)="IQEAM"
- DO ^DIC
- if Y<0
- QUIT
- DO @+Y
- GOTO A
- +2 ;
- 1 ;;Create Pull List
- CREATE IF '$DATA(RTDIV)
- DO DIV1^RTPSET
- IF '$DATA(RTDIV)
- DO MES^RTP4
- QUIT
- +1 WRITE !
- SET DIC("A")="Enter NEW PULL LIST NAME: "
- SET DIC(0)="IAELQ"
- SET DIC("S")="I 0"
- SET DIC("DR")="15////"_+RTAPL
- SET DIC="^RTV(194.2,"
- SET DLAYGO=194.2
- DO ^DIC
- KILL DIC
- if Y<0
- GOTO Q
- +2 KILL RTQDT,RTB,RTINST,RTSEL
- SET RTPLTY=2
- SET RTSHOW=""
- SET DIE("NO^")="OUTOK"
- SET (DA,RTPULL)=+Y
- SET DR="[RT PULL LIST]"
- SET DIE="^RTV(194.2,"
- DO ^DIE
- KILL RTSHOW,RTINST,RTPLTY,DIE,DE,DQ
- +3 IF $DATA(Y)
- WRITE !?3,*7,"...entry is incomplete"
- SET DIK="^RTV(194.2,"
- DO ^DIK
- KILL DIK
- WRITE "...pull list has been deleted."
- SET Y=""
- +4 if '$DATA(Y)
- DO ADD^RTP2
- KILL DLAYGO,DIC,RTESC,RTPULL
- Q KILL X1,A,DA,D0,DR,DIE,P,POP,RTC,RTY,%,%I,%H
- +1 KILL DIC,X,Y,J,I
- QUIT
- +2 ;
- 2 ;;Change Pull List Date
- +1 WRITE !
- SET DIC("S")="I $P(^(0),U,6)=""r"",'$P(^(0),U,13),$P(^(0),U,15)=+RTAPL"
- SET DIC(0)="IAEMQ"
- SET DIC="^RTV(194.2,"
- DO ^DIC
- KILL DIC
- if Y<0
- QUIT
- SET RTPULL=+Y
- +2 SET %DT="ATEFX"
- SET %DT("A")="Enter NEW Date: "
- SET %DT(0)="NOW"
- DO ^%DT
- KILL %DT
- if Y<0
- GOTO Q2
- SET RTQDT=Y
- +3 SET RTRD(1)="Yes^change the date"
- SET RTRD(2)="No^do not change the date"
- SET RTRD(0)="S"
- SET RTRD("B")=2
- SET RTRD("A")="Are you sure you want to change the date the records are needed? "
- DO SET^RTRD
- KILL RTRD
- if $EXTRACT(X)'="Y"
- GOTO Q2
- +4 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"
- WRITE "."
- SET DA=RTQ
- SET DR="4////"_RTQDT
- SET DIE="^RTV(190.1,"
- DO ^DIE
- KILL DE,DQ
- +5 SET DA=RTPULL
- SET DR="2////"_RTQDT
- SET DIE="^RTV(194.2,"
- DO ^DIE
- Q2 KILL DE,DQ,RTPULL,RTQDT,RTQ
- GOTO Q
- +1 ;
- 3 ;;Add Records Request to List
- +1 IF '$DATA(RTDIV)
- DO DIV1^RTPSET
- IF '$DATA(RTDIV)
- DO MES^RTP4
- QUIT
- +2 DO LIST
- if Y<0
- GOTO Q
- DO ADD^RTP2
- KILL DIC,RTESC,RTPULL
- GOTO Q
- +3 ;
- 4 ;;Cancel an Entire Pull List
- +1 DO LIST
- if Y<0
- GOTO Q4
- SET Y="cancel"
- DO ASK
- if $EXTRACT(X)'="Y"
- GOTO Q4
- SET RTSTAT="x"
- CAN 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"!($PIECE(^(0),"^",6)="n")
- SET DA=RTQ
- SET DIE="^RTV(190.1,"
- SET DR="[RT CHANGE REQUEST STATUS]"
- DO ^DIE
- KILL DE,DQ
- +1 KILL RTQ
- DO STAT
- WRITE !!?3,"...pull list has been cancelled"
- Q4 KILL RTPULL,RTSTAT
- +1 KILL DUOUT,X,Y,DIC,J
- GOTO Q
- +2 ;
- 5 ;;Designate Requests as Not Fillable
- +1 GOTO 5^RTP1
- +2 ;
- 6 ;;Charge Out Pull List
- +1 GOTO ^RTP4
- +2 ;
- 7 ;;Flag Pull List as PULLED/NOT CHARGED
- +1 ;D LIST Q:Y<0 S RTSTAT="p" G CAN
- +2 QUIT
- +3 ;
- 8 ;;Cancel Individual Requests from Pull List
- +1 GOTO 8^RTP1
- +2 ;
- 9 ;;Modify Pull List Comments
- +1 GOTO 9^RTP1
- +2 ;
- 10 ;;Pull List Print
- +1 GOTO ^RTP3
- +2 ;
- 11 ;;Special Multi-Institution Prints
- +1 GOTO ^RTP5
- +2 ;
- 12 ;;Cancel an Entire Pull list for all future dates
- +1 GOTO ALL^RTPCAN
- +2 ;
- LIST WRITE !
- SET DIC("S")="I $P(^(0),U,2)'<DT,$P(^(0),U,6)=""r"",$P(^(0),U,15)=+RTAPL"
- SET DIC(0)="IAEMQ"
- SET DIC="^RTV(194.2,"
- DO ^DIC
- KILL DIC
- if Y<0
- QUIT
- SET RTPULL=+Y
- QUIT
- +1 ;
- STAT SET DA=RTPULL
- SET DR="[RT CHANGE PULL LIST STATUS]"
- SET DIE="^RTV(194.2,"
- DO ^DIE
- KILL DE,DQ
- QUIT
- +1 ;
- ASK ;
- +1 SET RTRD(1)="Yes^"_Y_" entire pull list"
- SET RTRD(2)="No^not "_Y_" pull list"
- SET RTRD("B")=2
- SET RTRD("A")="Are you sure you want to "_Y_" this pull list? "
- SET RTRD(0)="S"
- DO SET^RTRD
- KILL RTRD
- QUIT
- +2 ;