source: FOIAVistA/tag/r/CMOP-PSX/PSXSRST.m@ 951

Last change on this file since 951 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.4 KB
Line 
1PSXSRST ;BIR/WPB-Reset Suspense and Print Again ;30 JAN 1998 12:57 PM
2 ;;2.0;CMOP;**3,23,41**;11 Apr 97
3 ;Reference to ^PS(52.5, supported by DBIA #1978
4 ;Reference to ^PS(59, supported by DBIA #1976
5 ;Reference to ^PSRX( supported by DBIA #1977
6 ;Reference to ^PSOLSET supported by DBIA #1973
7 ;Reference to EN^PSOHLSN1 supported by DBIA #2385
8 ;
9 Q:'$G(PSXVER)
10 D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) G END
11START W !!,"Select a date range to see all CMOP batches that have printed from suspense",!,"within that date range."
12BEG K ^TMP($J,"PSXRESP"),^TMP($J,"PSXRESPR"),^UTILITY($J,"PSXREPT"),PSXOUT,DTOUT
13 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
14 S BDT=BDT-.0001,ENDDATE=ENDDATE+.9999,RECNT=1 W !!,"Gathering batches, please wait...",! H 1
15 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
16 .I MMM=$G(PSOSITE) S ^TMP($J,"PSXRESP",RECNT,ZZZ,XXX,MMM)="",RECNT=RECNT+1,^TMP($J,"PSXZRST",ZZZ)=""
17 I '$D(^TMP($J,"PSXRESP")) W $C(7),!!,"There are no CMOP printed batches found for that date range!",! G BEG
18 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 "-"
19 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
20 .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
21 ..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 "-"
22 I $G(PSXOUT),Y="" G END
23 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
24 I Y["^"!($D(DTOUT))!($D(DUOUT)) W !!?3,$S($G(PSXFLAG)=1:"Nothing to Reset!",1:"Nothing queued to print!"),! G START
25 ;currently only checking Y, not Y(0),Y(1), etc. if list>245
26 S COUNT=1 F ZZ=1:1:$L(Y) S ZZZ=$E(Y,ZZ) I ZZZ="," S COUNT=COUNT+1
27 S COUNT=COUNT-1 F JJ=1:1:COUNT S RR=$P(Y,",",JJ),^TMP($J,"PSXRESPR",RR)=""
28 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
29 .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")
30 .W !,"Batch ",ZZZ," Printed on ",PSXDT," by ",PSXU
31 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
32 I Y["^"!($D(DTOUT)) W !!?3,$S($G(PSXFLAG)=1:"Nothing to Reset!",1:"Nothing queued to print!"),! G START
33 I Y D LIST I $G(PSXOUT) G BEG
34 G:$G(PSXFLAG)=1 TRANS
35 G:$G(PSXFLAG)=2 QUE^PSXSRP
36 Q
37TRANS 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
38 K TSK D OPTSTAT^XUTMOPT("PSXR SCHEDULED NON-CS TRANS",.TSK)
39 S ATM=$P($G(TSK(1)),U,2),ATM=$$FMTE^XLFDT(ATM)
40 K BCT,PDT,USR,DIV,SEQ,REC,RXN,CNT,DTTM,COM,JJ,RFCNT,RF,Y
41 S BCT=0 D NOW^%DTC S RSDT=$$FMTE^XLFDT(%,"1") K %
42 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
43 K BCT,PDT,USR,DIV,RSDT
44 I $G(ATM)'="" W !,"Next auto transmission scheduled for "_$G(ATM)
45 W !,"To transmit now use the Print from Suspense option, Initiate a CMOP Transmission"
46 K AUTOREC,ATM
47 ;the next two lines are commented out to, if specs change back to the
48 ;way version 1 works just uncomment these two lines and the user will
49 ;be prompted to do a transmission now
50 ;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
51 ;I $G(Y)>0 G BEGIN^PSXRSUS
52 Q
53TRANS1 Q:'$D(^PS(52.5,"APR",PDT,USR,DIV))
54 K DIE,DR
55 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
56 .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")
57 .D NOW^%DTC S DTTM=%,COM="CMOP Rx Reset to Transmit"
58 .S CNT=0 F JJ=0:0 S JJ=$O(^PSRX(RXN,"A",JJ)) Q:'JJ S CNT=JJ
59 .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
60 .S CNT=CNT+1,^PSRX(RXN,"A",0)="^52.3DA^"_CNT_"^"_CNT
61LOCK52 .L +^PSRX(RXN):DTIME G:'$T LOCK52 S ^PSRX(RXN,"A",CNT,0)=DTTM_"^S^"_USR_"^"_RFCNT_"^"_COM L -^PSRX(RXN)
62LOCK525 .S DA=REC L +^PS(52.5,REC):DTIME G:'$T LOCK525 S DR="3////Q" D ^DIE
63 .K ^PS(52.5,"ADL",$E($P(^PS(52.5,REC,0),"^",8),1,7),REC)
64 .S ^PS(52.5,REC,"P")=0,$P(^PS(52.5,REC,0),"^",8)="",$P(^(0),"^",9)="",$P(^(0),"^",11)=""
65 .K ^PS(52.5,"APR",PDT,USR,DIV,SEQ,REC)
66 .L -^PS(52.5,REC)
67 .K RXN,DA,CNT,DTTM,COM,JJ,RFCNT,RF,%
68 W !,"Batch ",$G(BCT)," Reset by ",$P(^VA(200,DUZ,0),"^")," on ",$G(RSDT)
69 K SEQ,REC
70 Q
71END 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
72 K PSRDATE,PSRDIV,PSRDUZ,RECNT,REDT,REDUZ,RR,SS,XXX,ZZ,ZZZ,ZZZ,ZZZZ,PSXFLAG D ^%ZISC Q
73LIST F LLL=0:0 S LLL=$O(^TMP($J,"PSXRESPR",LLL)) Q:'LLL!($G(PSXOUT)) D
74 .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
75 ..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
76 ...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:"")
77 I $G(PSXOUT),(Y="") Q
78 S PSXOUT=0 I Y'=0 W !,"END OF LIST"
79 Q
80HEAD W @IOF W !,"RX #",?20,"PATIENT NAME",?60,"BATCH ",LLL,! F ZZZZ=1:1:78 W "-"
81 Q
82HEADONE S DIR(0)="E" D ^DIR K DIR I 'Y S PSXOUT=1 Q
83 W @IOF W !,"RX #",?20,"PATIENT NAME",?60,"BATCH ",LLL,! F ZZZZ=1:1:78 W "-"
84 Q
Note: See TracBrowser for help on using the repository browser.