- PSXSRST ;BIR/WPB-Reset Suspense and Print Again ;30 JAN 1998 12:57 PM
- ;;2.0;CMOP;**3,23,41**;11 Apr 97
- ;Reference to ^PS(52.5, supported by DBIA #1978
- ;Reference to ^PS(59, supported by DBIA #1976
- ;Reference to ^PSRX( supported by DBIA #1977
- ;Reference to ^PSOLSET supported by DBIA #1973
- ;Reference to EN^PSOHLSN1 supported by DBIA #2385
- ;
- Q:'$G(PSXVER)
- D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) G END
- START W !!,"Select a date range to see all CMOP batches that have printed from suspense",!,"within that date range."
- BEG K ^TMP($J,"PSXRESP"),^TMP($J,"PSXRESPR"),^UTILITY($J,"PSXREPT"),PSXOUT,DTOUT
- W ! K %DT S %DT="AEX",%DT("A")="START DATE: " D ^%DT K %DT G:Y<0!($D(DTOUT)) END S (%DT(0),BDT)=Y W ! S %DT="AEX",%DT("A")="END DATE: " D ^%DT K %DT G:Y<0!($D(DTOUT)) END S ENDDATE=Y
- S BDT=BDT-.0001,ENDDATE=ENDDATE+.9999,RECNT=1 W !!,"Gathering batches, please wait...",! H 1
- F ZZZ=BDT:0 S ZZZ=$O(^PS(52.5,"APR",ZZZ)) Q:'ZZZ!(ZZZ>ENDDATE) F XXX=0:0 S XXX=$O(^PS(52.5,"APR",ZZZ,XXX)) Q:'XXX F MMM=0:0 S MMM=$O(^PS(52.5,"APR",ZZZ,XXX,MMM)) Q:'MMM D
- .I MMM=$G(PSOSITE) S ^TMP($J,"PSXRESP",RECNT,ZZZ,XXX,MMM)="",RECNT=RECNT+1,^TMP($J,"PSXZRST",ZZZ)=""
- I '$D(^TMP($J,"PSXRESP")) W $C(7),!!,"There are no CMOP printed batches found for that date range!",! G BEG
- H 1 W @IOF W !?1,"BATCH",?10,"PRINTED ON:",?40,"PRINTED BY:",?56,$E($P($G(^PS(59,PSOSITE,0)),"^"),1,23),! F AA=1:1:78 W "-"
- W ! F AAA=0:0 S AAA=$O(^TMP($J,"PSXRESP",AAA)) Q:'AAA!($G(PSXOUT)) S PSIDATE=$O(^TMP($J,"PSXRESP",AAA,0)),XDUZ=$O(^TMP($J,"PSXRESP",AAA,PSIDATE,0)) D
- .S Y=PSIDATE X ^DD("DD") S PSXDT=Y,PSXU=$S($D(^VA(200,XDUZ,0)):$P($G(^(0)),"^"),1:"UNKNOWN") D:($Y+5)>IOSL Q:$G(PSXOUT) W !?2,AAA,?10,PSXDT,?40,PSXU
- ..W ! K DIR S DIR(0)="E" D ^DIR K DIR S:'Y PSXOUT=1 I Y W @IOF W !?1,"BATCH",?10,"PRINTED ON:",?40,"PRINTED BY:",?56,$E($P($G(^PS(59,PSOSITE,0)),"^"),1,23),! F AA=1:1:78 W "-"
- I $G(PSXOUT),Y="" G END
- S RECNT=RECNT-1,PSXOUT=0 W ! K DIR S DIR("A")="Select Batch(s) to "_$S($G(PSXFLAG)=1:"reset",$G(PSXFLAG)=2:"reprint",1:""),DIR(0)="L^1:"_RECNT D ^DIR K DIR
- I Y["^"!($D(DTOUT))!($D(DUOUT)) W !!?3,$S($G(PSXFLAG)=1:"Nothing to Reset!",1:"Nothing queued to print!"),! G START
- ;currently only checking Y, not Y(0),Y(1), etc. if list>245
- S COUNT=1 F ZZ=1:1:$L(Y) S ZZZ=$E(Y,ZZ) I ZZZ="," S COUNT=COUNT+1
- S COUNT=COUNT-1 F JJ=1:1:COUNT S RR=$P(Y,",",JJ),^TMP($J,"PSXRESPR",RR)=""
- W !!,"Batches selected for "_$S($G(PSXFLAG)=1:"Reset",1:"Reprint")_" are:",! F ZZZ=0:0 S ZZZ=$O(^TMP($J,"PSXRESPR",ZZZ)) Q:'ZZZ D
- .S PSIDATE=$O(^TMP($J,"PSXRESP",ZZZ,0)),XDUZ=$O(^TMP($J,"PSXRESP",ZZZ,PSIDATE,0)) S Y=PSIDATE X ^DD("DD") S PSXDT=Y,PSXU=$S($D(^VA(200,XDUZ,0)):$P($G(^(0)),"^"),1:"UNKNOWN")
- .W !,"Batch ",ZZZ," Printed on ",PSXDT," by ",PSXU
- W ! K DIR S DIR(0)="Y",DIR("B")="N",DIR("A")="Before "_$S($G(PSXFLAG)=1:"Resetting",1:"Queuing")_" would you like a list of these prescriptions" D ^DIR K DIR
- I Y["^"!($D(DTOUT)) W !!?3,$S($G(PSXFLAG)=1:"Nothing to Reset!",1:"Nothing queued to print!"),! G START
- I Y D LIST I $G(PSXOUT) G BEG
- G:$G(PSXFLAG)=1 TRANS
- G:$G(PSXFLAG)=2 QUE^PSXSRP
- Q
- TRANS K DIR,Y,X S DIR(0)="Y",DIR("B")="NO",DIR("A")="Reset for Transmission" D ^DIR K DIR I Y="^"!($D(DTOUT))!($G(Y)<1) W !!,"Nothing Reset for Transmission!",! G START
- K TSK D OPTSTAT^XUTMOPT("PSXR SCHEDULED NON-CS TRANS",.TSK)
- S ATM=$P($G(TSK(1)),U,2),ATM=$$FMTE^XLFDT(ATM)
- K BCT,PDT,USR,DIV,SEQ,REC,RXN,CNT,DTTM,COM,JJ,RFCNT,RF,Y
- S BCT=0 D NOW^%DTC S RSDT=$$FMTE^XLFDT(%,"1") K %
- F S BCT=$O(^TMP($J,"PSXRESPR",BCT)) Q:BCT'>0 S PDT="" F S PDT=$O(^TMP($J,"PSXRESP",BCT,PDT)) Q:'PDT S USR=0 F S USR=$O(^TMP($J,"PSXRESP",BCT,PDT,USR)) Q:USR'>0 S DIV=0 F S DIV=$O(^TMP($J,"PSXRESP",BCT,PDT,USR,DIV)) Q:DIV'>0 D TRANS1
- K BCT,PDT,USR,DIV,RSDT
- I $G(ATM)'="" W !,"Next auto transmission scheduled for "_$G(ATM)
- W !,"To transmit now use the Print from Suspense option, Initiate a CMOP Transmission"
- K AUTOREC,ATM
- ;the next two lines are commented out to, if specs change back to the
- ;way version 1 works just uncomment these two lines and the user will
- ;be prompted to do a transmission now
- ;K DIR,Y,X S DIR(0)="Y",DIR("B")="NO",DIR("A")="DO YOU WANT TO TRANSMIT TO CMOP NOW" D ^DIR K DIR I Y["^"!($D(DTOUT))!($D(DIROUT))!($D(DIRUT))!($G(Y)=0) G END
- ;I $G(Y)>0 G BEGIN^PSXRSUS
- Q
- TRANS1 Q:'$D(^PS(52.5,"APR",PDT,USR,DIV))
- K DIE,DR
- S SEQ=0,DIE="^PS(52.5,",DR="3////Q" F S SEQ=$O(^PS(52.5,"APR",PDT,USR,DIV,SEQ)) Q:SEQ'>0 S REC=0 F S REC=$O(^PS(52.5,"APR",PDT,USR,DIV,SEQ,REC)) Q:REC'>0 D
- .S RXN=$P($G(^PS(52.5,REC,0)),"^"),$P(^PSRX(RXN,"STA"),"^",1)=5 D EN^PSOHLSN1(RXN,"SC","ZS","CMOP Rx Reset to Transmit")
- .D NOW^%DTC S DTTM=%,COM="CMOP Rx Reset to Transmit"
- .S CNT=0 F JJ=0:0 S JJ=$O(^PSRX(RXN,"A",JJ)) Q:'JJ S CNT=JJ
- .S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(RXN,1,RF)) Q:'RF S RFCNT=RF S:RF>5 RFCNT=RF+1
- .S CNT=CNT+1,^PSRX(RXN,"A",0)="^52.3DA^"_CNT_"^"_CNT
- LOCK52 .L +^PSRX(RXN):DTIME G:'$T LOCK52 S ^PSRX(RXN,"A",CNT,0)=DTTM_"^S^"_USR_"^"_RFCNT_"^"_COM L -^PSRX(RXN)
- LOCK525 .S DA=REC L +^PS(52.5,REC):DTIME G:'$T LOCK525 S DR="3////Q" D ^DIE
- .K ^PS(52.5,"ADL",$E($P(^PS(52.5,REC,0),"^",8),1,7),REC)
- .S ^PS(52.5,REC,"P")=0,$P(^PS(52.5,REC,0),"^",8)="",$P(^(0),"^",9)="",$P(^(0),"^",11)=""
- .K ^PS(52.5,"APR",PDT,USR,DIV,SEQ,REC)
- .L -^PS(52.5,REC)
- .K RXN,DA,CNT,DTTM,COM,JJ,RFCNT,RF,%
- W !,"Batch ",$G(BCT)," Reset by ",$P(^VA(200,DUZ,0),"^")," on ",$G(RSDT)
- K SEQ,REC
- Q
- END K ^TMP($J,"PSXRESPR"),^UTILITY($J,"PSXREPT"),%DT,%ZIS,AA,AAA,BDT,COUNT,DUOUT,DTOUT,ENDDATE,GG,INRX,JJ,LLL,MMM,NNN,POP,PSIDATE,PSXDT,XDUZ,PSXDEV,TIME,PSXREP,PSXU
- K PSRDATE,PSRDIV,PSRDUZ,RECNT,REDT,REDUZ,RR,SS,XXX,ZZ,ZZZ,ZZZ,ZZZZ,PSXFLAG D ^%ZISC Q
- LIST F LLL=0:0 S LLL=$O(^TMP($J,"PSXRESPR",LLL)) Q:'LLL!($G(PSXOUT)) D
- .W ! S DIR(0)="E" D ^DIR K DIR S:'Y PSXOUT=1 Q:$G(PSXOUT) D HEAD S REDT=$O(^TMP($J,"PSXRESP",LLL,0)),REDUZ=$O(^TMP($J,"PSXRESP",LLL,REDT,0)) F SS=0:0 S SS=$O(^PS(52.5,"APR",REDT,REDUZ,PSOSITE,SS)) Q:'SS!($G(PSXOUT)) D
- ..F GG=0:0 S GG=$O(^PS(52.5,"APR",REDT,REDUZ,PSOSITE,SS,GG)) Q:'GG!($G(PSXOUT)) D:($Y+5)>IOSL HEADONE Q:$G(PSXOUT) I $D(^PS(52.5,GG,0)),$P($G(^(0)),"^",6)=PSOSITE S INRX=$P(^(0),"^") I $D(^PSRX(INRX,0)) D
- ...W !,$P(^PSRX(INRX,0),"^"),?20,$P($G(^DPT(+$P(^PSRX(INRX,0),"^",2),0)),"^"),?60,$S($P($G(^PS(52.5,GG,0)),"^",5):"(PARTIAL)",$P($G(^(0)),"^",12):"(REPRINT)",1:"")
- I $G(PSXOUT),(Y="") Q
- S PSXOUT=0 I Y'=0 W !,"END OF LIST"
- Q
- HEAD W @IOF W !,"RX #",?20,"PATIENT NAME",?60,"BATCH ",LLL,! F ZZZZ=1:1:78 W "-"
- Q
- HEADONE S DIR(0)="E" D ^DIR K DIR I 'Y S PSXOUT=1 Q
- W @IOF W !,"RX #",?20,"PATIENT NAME",?60,"BATCH ",LLL,! F ZZZZ=1:1:78 W "-"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXSRST 6676 printed Mar 13, 2025@20:49:54 Page 2
- PSXSRST ;BIR/WPB-Reset Suspense and Print Again ;30 JAN 1998 12:57 PM
- +1 ;;2.0;CMOP;**3,23,41**;11 Apr 97
- +2 ;Reference to ^PS(52.5, supported by DBIA #1978
- +3 ;Reference to ^PS(59, supported by DBIA #1976
- +4 ;Reference to ^PSRX( supported by DBIA #1977
- +5 ;Reference to ^PSOLSET supported by DBIA #1973
- +6 ;Reference to EN^PSOHLSN1 supported by DBIA #2385
- +7 ;
- +8 if '$GET(PSXVER)
- QUIT
- +9 if '$DATA(PSOPAR)
- DO ^PSOLSET
- IF '$DATA(PSOPAR)
- GOTO END
- START WRITE !!,"Select a date range to see all CMOP batches that have printed from suspense",!,"within that date range."
- BEG KILL ^TMP($JOB,"PSXRESP"),^TMP($JOB,"PSXRESPR"),^UTILITY($JOB,"PSXREPT"),PSXOUT,DTOUT
- +1 WRITE !
- KILL %DT
- SET %DT="AEX"
- SET %DT("A")="START DATE: "
- DO ^%DT
- KILL %DT
- if Y<0!($DATA(DTOUT))
- GOTO END
- SET (%DT(0),BDT)=Y
- WRITE !
- SET %DT="AEX"
- SET %DT("A")="END DATE: "
- DO ^%DT
- KILL %DT
- if Y<0!($DATA(DTOUT))
- GOTO END
- SET ENDDATE=Y
- +2 SET BDT=BDT-.0001
- SET ENDDATE=ENDDATE+.9999
- SET RECNT=1
- WRITE !!,"Gathering batches, please wait...",!
- HANG 1
- +3 FOR ZZZ=BDT:0
- SET ZZZ=$ORDER(^PS(52.5,"APR",ZZZ))
- if 'ZZZ!(ZZZ>ENDDATE)
- QUIT
- FOR XXX=0:0
- SET XXX=$ORDER(^PS(52.5,"APR",ZZZ,XXX))
- if 'XXX
- QUIT
- FOR MMM=0:0
- SET MMM=$ORDER(^PS(52.5,"APR",ZZZ,XXX,MMM))
- if 'MMM
- QUIT
- Begin DoDot:1
- +4 IF MMM=$GET(PSOSITE)
- SET ^TMP($JOB,"PSXRESP",RECNT,ZZZ,XXX,MMM)=""
- SET RECNT=RECNT+1
- SET ^TMP($JOB,"PSXZRST",ZZZ)=""
- End DoDot:1
- +5 IF '$DATA(^TMP($JOB,"PSXRESP"))
- WRITE $CHAR(7),!!,"There are no CMOP printed batches found for that date range!",!
- GOTO BEG
- +6 HANG 1
- WRITE @IOF
- WRITE !?1,"BATCH",?10,"PRINTED ON:",?40,"PRINTED BY:",?56,$EXTRACT($PIECE($GET(^PS(59,PSOSITE,0)),"^"),1,23),!
- FOR AA=1:1:78
- WRITE "-"
- +7 WRITE !
- FOR AAA=0:0
- SET AAA=$ORDER(^TMP($JOB,"PSXRESP",AAA))
- if 'AAA!($GET(PSXOUT))
- QUIT
- SET PSIDATE=$ORDER(^TMP($JOB,"PSXRESP",AAA,0))
- SET XDUZ=$ORDER(^TMP($JOB,"PSXRESP",AAA,PSIDATE,0))
- Begin DoDot:1
- +8 SET Y=PSIDATE
- XECUTE ^DD("DD")
- SET PSXDT=Y
- SET PSXU=$SELECT($DATA(^VA(200,XDUZ,0)):$PIECE($GET(^(0)),"^"),1:"UNKNOWN")
- if ($Y+5)>IOSL
- Begin DoDot:2
- +9 WRITE !
- KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- if 'Y
- SET PSXOUT=1
- IF Y
- WRITE @IOF
- WRITE !?1,"BATCH",?10,"PRINTED ON:",?40,"PRINTED BY:",?56,$EXTRACT($PIECE($GET(^PS(59,PSOSITE,0)),"^"),1,23),!
- FOR AA=1:1:78
- WRITE "-"
- End DoDot:2
- if $GET(PSXOUT)
- QUIT
- WRITE !?2,AAA,?10,PSXDT,?40,PSXU
- End DoDot:1
- +10 IF $GET(PSXOUT)
- IF Y=""
- GOTO END
- +11 SET RECNT=RECNT-1
- SET PSXOUT=0
- WRITE !
- KILL DIR
- SET DIR("A")="Select Batch(s) to "_$SELECT($GET(PSXFLAG)=1:"reset",$GET(PSXFLAG)=2:"reprint",1:"")
- SET DIR(0)="L^1:"_RECNT
- DO ^DIR
- KILL DIR
- +12 IF Y["^"!($DATA(DTOUT))!($DATA(DUOUT))
- WRITE !!?3,$SELECT($GET(PSXFLAG)=1:"Nothing to Reset!",1:"Nothing queued to print!"),!
- GOTO START
- +13 ;currently only checking Y, not Y(0),Y(1), etc. if list>245
- +14 SET COUNT=1
- FOR ZZ=1:1:$LENGTH(Y)
- SET ZZZ=$EXTRACT(Y,ZZ)
- IF ZZZ=","
- SET COUNT=COUNT+1
- +15 SET COUNT=COUNT-1
- FOR JJ=1:1:COUNT
- SET RR=$PIECE(Y,",",JJ)
- SET ^TMP($JOB,"PSXRESPR",RR)=""
- +16 WRITE !!,"Batches selected for "_$SELECT($GET(PSXFLAG)=1:"Reset",1:"Reprint")_" are:",!
- FOR ZZZ=0:0
- SET ZZZ=$ORDER(^TMP($JOB,"PSXRESPR",ZZZ))
- if 'ZZZ
- QUIT
- Begin DoDot:1
- +17 SET PSIDATE=$ORDER(^TMP($JOB,"PSXRESP",ZZZ,0))
- SET XDUZ=$ORDER(^TMP($JOB,"PSXRESP",ZZZ,PSIDATE,0))
- SET Y=PSIDATE
- XECUTE ^DD("DD")
- SET PSXDT=Y
- SET PSXU=$SELECT($DATA(^VA(200,XDUZ,0)):$PIECE($GET(^(0)),"^"),1:"UNKNOWN")
- +18 WRITE !,"Batch ",ZZZ," Printed on ",PSXDT," by ",PSXU
- End DoDot:1
- +19 WRITE !
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("B")="N"
- SET DIR("A")="Before "_$SELECT($GET(PSXFLAG)=1:"Resetting",1:"Queuing")_" would you like a list of these prescriptions"
- DO ^DIR
- KILL DIR
- +20 IF Y["^"!($DATA(DTOUT))
- WRITE !!?3,$SELECT($GET(PSXFLAG)=1:"Nothing to Reset!",1:"Nothing queued to print!"),!
- GOTO START
- +21 IF Y
- DO LIST
- IF $GET(PSXOUT)
- GOTO BEG
- +22 if $GET(PSXFLAG)=1
- GOTO TRANS
- +23 if $GET(PSXFLAG)=2
- GOTO QUE^PSXSRP
- +24 QUIT
- TRANS KILL DIR,Y,X
- SET DIR(0)="Y"
- SET DIR("B")="NO"
- SET DIR("A")="Reset for Transmission"
- DO ^DIR
- KILL DIR
- IF Y="^"!($DATA(DTOUT))!($GET(Y)<1)
- WRITE !!,"Nothing Reset for Transmission!",!
- GOTO START
- +1 KILL TSK
- DO OPTSTAT^XUTMOPT("PSXR SCHEDULED NON-CS TRANS",.TSK)
- +2 SET ATM=$PIECE($GET(TSK(1)),U,2)
- SET ATM=$$FMTE^XLFDT(ATM)
- +3 KILL BCT,PDT,USR,DIV,SEQ,REC,RXN,CNT,DTTM,COM,JJ,RFCNT,RF,Y
- +4 SET BCT=0
- DO NOW^%DTC
- SET RSDT=$$FMTE^XLFDT(%,"1")
- KILL %
- +5 FOR
- SET BCT=$ORDER(^TMP($JOB,"PSXRESPR",BCT))
- if BCT'>0
- QUIT
- SET PDT=""
- FOR
- SET PDT=$ORDER(^TMP($JOB,"PSXRESP",BCT,PDT))
- if 'PDT
- QUIT
- SET USR=0
- FOR
- SET USR=$ORDER(^TMP($JOB,"PSXRESP",BCT,PDT,USR))
- if USR'>0
- QUIT
- SET DIV=0
- FOR
- SET DIV=$ORDER(^TMP($JOB,"PSXRESP",BCT,PDT,USR,DIV))
- if DIV'>0
- QUIT
- DO TRANS1
- +6 KILL BCT,PDT,USR,DIV,RSDT
- +7 IF $GET(ATM)'=""
- WRITE !,"Next auto transmission scheduled for "_$GET(ATM)
- +8 WRITE !,"To transmit now use the Print from Suspense option, Initiate a CMOP Transmission"
- +9 KILL AUTOREC,ATM
- +10 ;the next two lines are commented out to, if specs change back to the
- +11 ;way version 1 works just uncomment these two lines and the user will
- +12 ;be prompted to do a transmission now
- +13 ;K DIR,Y,X S DIR(0)="Y",DIR("B")="NO",DIR("A")="DO YOU WANT TO TRANSMIT TO CMOP NOW" D ^DIR K DIR I Y["^"!($D(DTOUT))!($D(DIROUT))!($D(DIRUT))!($G(Y)=0) G END
- +14 ;I $G(Y)>0 G BEGIN^PSXRSUS
- +15 QUIT
- TRANS1 if '$DATA(^PS(52.5,"APR",PDT,USR,DIV))
- QUIT
- +1 KILL DIE,DR
- +2 SET SEQ=0
- SET DIE="^PS(52.5,"
- SET DR="3////Q"
- FOR
- SET SEQ=$ORDER(^PS(52.5,"APR",PDT,USR,DIV,SEQ))
- if SEQ'>0
- QUIT
- SET REC=0
- FOR
- SET REC=$ORDER(^PS(52.5,"APR",PDT,USR,DIV,SEQ,REC))
- if REC'>0
- QUIT
- Begin DoDot:1
- +3 SET RXN=$PIECE($GET(^PS(52.5,REC,0)),"^")
- SET $PIECE(^PSRX(RXN,"STA"),"^",1)=5
- DO EN^PSOHLSN1(RXN,"SC","ZS","CMOP Rx Reset to Transmit")
- +4 DO NOW^%DTC
- SET DTTM=%
- SET COM="CMOP Rx Reset to Transmit"
- +5 SET CNT=0
- FOR JJ=0:0
- SET JJ=$ORDER(^PSRX(RXN,"A",JJ))
- if 'JJ
- QUIT
- SET CNT=JJ
- +6 SET RFCNT=0
- FOR RF=0:0
- SET RF=$ORDER(^PSRX(RXN,1,RF))
- if 'RF
- QUIT
- SET RFCNT=RF
- if RF>5
- SET RFCNT=RF+1
- +7 SET CNT=CNT+1
- SET ^PSRX(RXN,"A",0)="^52.3DA^"_CNT_"^"_CNT
- LOCK52 LOCK +^PSRX(RXN):DTIME
- if '$TEST
- GOTO LOCK52
- SET ^PSRX(RXN,"A",CNT,0)=DTTM_"^S^"_USR_"^"_RFCNT_"^"_COM
- LOCK -^PSRX(RXN)
- LOCK525 SET DA=REC
- LOCK +^PS(52.5,REC):DTIME
- if '$TEST
- GOTO LOCK525
- SET DR="3////Q"
- DO ^DIE
- +1 KILL ^PS(52.5,"ADL",$EXTRACT($PIECE(^PS(52.5,REC,0),"^",8),1,7),REC)
- +2 SET ^PS(52.5,REC,"P")=0
- SET $PIECE(^PS(52.5,REC,0),"^",8)=""
- SET $PIECE(^(0),"^",9)=""
- SET $PIECE(^(0),"^",11)=""
- +3 KILL ^PS(52.5,"APR",PDT,USR,DIV,SEQ,REC)
- +4 LOCK -^PS(52.5,REC)
- +5 KILL RXN,DA,CNT,DTTM,COM,JJ,RFCNT,RF,%
- End DoDot:1
- +6 WRITE !,"Batch ",$GET(BCT)," Reset by ",$PIECE(^VA(200,DUZ,0),"^")," on ",$GET(RSDT)
- +7 KILL SEQ,REC
- +8 QUIT
- END KILL ^TMP($JOB,"PSXRESPR"),^UTILITY($JOB,"PSXREPT"),%DT,%ZIS,AA,AAA,BDT,COUNT,DUOUT,DTOUT,ENDDATE,GG,INRX,JJ,LLL,MMM,NNN,POP,PSIDATE,PSXDT,XDUZ,PSXDEV,TIME,PSXREP,PSXU
- +1 KILL PSRDATE,PSRDIV,PSRDUZ,RECNT,REDT,REDUZ,RR,SS,XXX,ZZ,ZZZ,ZZZ,ZZZZ,PSXFLAG
- DO ^%ZISC
- QUIT
- LIST FOR LLL=0:0
- SET LLL=$ORDER(^TMP($JOB,"PSXRESPR",LLL))
- if 'LLL!($GET(PSXOUT))
- QUIT
- Begin DoDot:1
- +1 WRITE !
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- if 'Y
- SET PSXOUT=1
- if $GET(PSXOUT)
- QUIT
- DO HEAD
- SET REDT=$ORDER(^TMP($JOB,"PSXRESP",LLL,0))
- SET REDUZ=$ORDER(^TMP($JOB,"PSXRESP",LLL,REDT,0))
- FOR SS=0:0
- SET SS=$ORDER(^PS(52.5,"APR",REDT,REDUZ,PSOSITE,SS))
- if 'SS!($GET(PSXOUT))
- QUIT
- Begin DoDot:2
- +2 FOR GG=0:0
- SET GG=$ORDER(^PS(52.5,"APR",REDT,REDUZ,PSOSITE,SS,GG))
- if 'GG!($GET(PSXOUT))
- QUIT
- if ($Y+5)>IOSL
- DO HEADONE
- if $GET(PSXOUT)
- QUIT
- IF $DATA(^PS(52.5,GG,0))
- IF $PIECE($GET(^(0)),"^",6)=PSOSITE
- SET INRX=$PIECE(^(0),"^")
- IF $DATA(^PSRX(INRX,0))
- Begin DoDot:3
- +3 WRITE !,$PIECE(^PSRX(INRX,0),"^"),?20,$PIECE($GET(^DPT(+$PIECE(^PSRX(INRX,0),"^",2),0)),"^"),?60,$SELECT($PIECE($GET(^PS(52.5,GG,0)),"^",5):"(PARTIAL)",$PIECE($GET(^(0)),"^",12):"(REPRINT)",1:"")
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +4 IF $GET(PSXOUT)
- IF (Y="")
- QUIT
- +5 SET PSXOUT=0
- IF Y'=0
- WRITE !,"END OF LIST"
- +6 QUIT
- HEAD WRITE @IOF
- WRITE !,"RX #",?20,"PATIENT NAME",?60,"BATCH ",LLL,!
- FOR ZZZZ=1:1:78
- WRITE "-"
- +1 QUIT
- HEADONE SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- IF 'Y
- SET PSXOUT=1
- QUIT
- +1 WRITE @IOF
- WRITE !,"RX #",?20,"PATIENT NAME",?60,"BATCH ",LLL,!
- FOR ZZZZ=1:1:78
- WRITE "-"
- +2 QUIT
