PSXRTRAN ;BIR/WPB/PDW-Batch Retransmission Routine ;13 Mar 2002 3:09 PM
;;2.0;CMOP;**18,27,31,41,51**;11 Apr 97
;Reference to ^PS(59, supported by DBIA #1976
;Reference to ^PS(59.7 supported by DBIA #694
;Reference to ^PSRX( supported by DBIA #1977
;
START I '$D(^XUSEC("PSXCMOPMGR",DUZ)) D NO Q
I '$D(^XUSEC("PSXRTRAN",DUZ)) D NO Q
I '$D(^XUSEC("PSX XMIT",DUZ)) D NO Q
D SET^PSXSYS
I '$D(PSXSYS) W !,"CMOP processing is inactivated, re-transmission of data not allowed." Q
S PSXJOB=2
I $D(^PSX(550,"TR","T")) W !,"There is another job in progress, try again later." G EXIT
L +PSX(550.1):3 I '$T W !,"There is another job in progress, try again later." G EXIT
I '$D(^PSX(550.2,"AX")) W !!,"No data to re-transmit." G EXIT
S DIC="^PSX(550.2,",DIC(0)="AMZEQ",DIC("S")="I ($D(^PSX(550.2,""AX"",+Y))),($P($G(^PSX(550.2,+Y,1)),U,3)=""""),($P($G(^PSX(550.2,+Y,1)),U,1)="""")"
D ^DIC K DIC,DIC("S"),DIC(0)
G:$D(DTOUT)!($D(DUOUT))!($G(Y)'>0) EXIT
S OLDBAT=+Y K Y,TRAN,TRANI
D GETS^DIQ(550.2,OLDBAT,".01;2;3;5;14;17","","TRAN"),TOP^PSXUTL("TRAN") ;external of fields
D GETS^DIQ(550.2,OLDBAT,".01;2;3;5;14;17","I","TRANI"),TOP^PSXUTL("TRANI") ;internal of fields
S OLDBATNM=TRAN(.01)
W !,"Transmission: "_TRAN(.01)
W !,"Date: "_TRAN(5)
W !,"Division: "_TRAN(2)
W !,"Type: "_TRAN(17)
W !,"CMOP Host: "_TRAN(3)
W !,"Total RXs: "_TRAN(14)
S TYP=$S(TRANI(17)="C":"CS",1:"STD")
S PSXCS=$S(TYP="CS":1,1:0) D SET^PSXSYS
I TRANI(3)'=+PSXSYS W !!,$$GET1^DIQ(550,+PSXSYS,.01)_" is the active host for transmitting "_TRAN(17) G EXIT
CLOSED S CLOSED=$P($G(^PSX(550.2,OLDBAT,1)),U,1)
I CLOSED'="" W !,"The transmission selected has been acknowledged and cannot be re-transmitted." D RESET G EXIT
I $P($G(^PSX(550.2,OLDBAT,1)),U,2)'="" W !!,"This transmission has been re-transmitted once and cannot",!,"be retransmitted again." D RESET G ERRMSG^PSXERR1
W !!
S BMSG=$P($G(^PSX(550.2,OLDBAT,1)),U,5)-1,EMSG=$P($G(^PSX(550.2,OLDBAT,1)),U,6),PSOSITE=$P($G(^PSX(550.2,OLDBAT,0)),"^",3)
S PSXSTART=BMSG+1,PSXDUZ=DUZ,PSXSITE=$P($G(PSXSYS),U,3)
S SNDR=$$GET1^DIQ(200,$P($G(^PSX(550.2,OLDBAT,0)),U,5),.01)
S DIV=$P($G(^PS(59,$P($G(^PSX(550.2,OLDBAT,0)),U,3),0)),U,1),Y=$P($G(^PSX(550.2,OLDBAT,0)),U,6) X ^DD("DD") S TRNDT=Y
W !," *** Coordinate re-transmissions with ",$$GET1^DIQ(550,+PSXSYS,.01)," CMOP ***",!
S DIR(0)="Y^O",DIR("B")="NO",DIR("A")="Are you sure you want to Re-transmit this batch" D ^DIR K DIR
I Y=0!($D(DIRUT)) D RESET G EXIT
QUE ;
F YY="PSXMFLAG","BMSG","EMSG","PSXSYS","OLDBAT*","PSXDUZ","PSXJOB","PSXSITE","PSOSITE","PSXSTART","PSXJOB","PSXSITE","TRAN*","PSXCS" S ZTSAVE(YY)=""
S ZTDTH=$H,ZTSAVE("ZZDATA")="",ZTIO="",ZTRTN="ENTRAN^PSXRTRAN",ZTDESC="CMOP Retransmission"
D ^%ZTLOAD ;****TESTING
;D ENTRAN S PSXSTAT="H" D PSXSTAT^PSXRSYU G EXIT ;****TESTING ;to run in the foreground uncomment this line and comment out the previous line
I $D(ZTSK)[0 W !!,"Job Cancelled" G EXIT
E W !!,"Re-transmission Queued "_ZTSK
S PSXSTAT="T" D PSXSTAT^PSXRSYU
G EXIT
TXT I $G(ORD)]"" S LCNT=LCNT+1,^XMB(3.9,XMZ,2,LCNT,0)=ORD
Q
ENTRAN ;Entry for data transmission
LOCK ; >>>**** LOCK OF FILE 550.1 ****<<<
F I=1:1:3 L +^PSX(550.1):6 I $T S I=100
I I'=100 D CANMSG G EXIT ; could not get a lock in 18 minutes of waiting
K ^TMP($J,"PSX"),^TMP($J,"PSXDFN"),ZCNT,PSXBAT
S PSOPAR=^PS(59,PSOSITE,1)
S PSXTDIV=PSOSITE,PSXTYP=$S(+$G(PSXCS):"C",1:"N")
S PSOLAP=ION,PSOSYS=$G(^PS(59.7,1,40.1)),PSXTRANS=1,PSXFLAG=1
S PSOINST=+$P(PSXSYS,"^",2)
S PSXVENDR="AUTOMATED SYSTEM"
S PSXRTRAN=1,PSXRTRN=1,ZTREQ="@"
RESETRX ; pull, reset RXs from 550.2 RX multiple, if released do not send, make report
K ^TMP($J,"PSXRTRAN"),LCNT
S PSXERFLG=0 S PSXFLAG=1,PSXRTRAN=1
F NI=1:1 Q:'$D(^PSX(550.2,OLDBAT,15,NI,0)) S XX=^(0) D
. N NI
. S RXDA=$P(XX,U,1),FILL=$P(XX,U,2),DFN=$P(XX,U,3),REC=$P(XX,U,5)
. S TEST=$$TESTREL(RXDA,FILL) ; test & catalog RXs for report, 'SENT' if OK, "FILL '=" if more recent fill, 'released date' if released
. Q:TEST'="SENT"
. Q:'$D(^PS(52.5,"B",RXDA)) ;RX pulled early from suspense
. D RESET^PSXNEW(RXDA,FILL,"Re-Trans of "_OLDBAT)
. D SDT ;test/set RX into 550.2
;
I '$G(PSXBAT) D NOTRAN G EXIT ;no RXs passed retesting
I PSXERFLG=1 S PSXJOB=7 D ^PSXERR
D EN^PSXBLD ; build 550.1 entries related to PSXBAT
I PSXERFLG=1 S PFLAG=1 D EN^PSXERR
S OLDSDT=$P($G(^PSX(550.2,OLDBAT,0)),"^",6)
S PSXSENDR=$$GET1^DIQ(200,PSXDUZ,.01),(SITEN,SITENUM)=$P($G(PSXSYS),U,2),PSXEND=EMSG,PSXDIV=$P($G(^PS(59,+PSOSITE,0)),U,1),XSITE=$P($G(^PS(59,+PSOSITE,0)),U,6)
S PSXSTART=$O(^PSX(550.1,"C",PSXBAT,0)),(PSXEND,EMSG)=$O(^PSX(550.1,"C",PSXBAT,"A"),-1)
S PSXBATNM=$$GET1^DIQ(550.2,PSXBAT,.01)
S PSXHDR=PSXSITE_U_+PSXSYS_U_SITENUM_U_PSXTDT_U_PSXSENDR_U_PSXSTART_U_EMSG_U_PSXDIV_U_XSITE,PSXREF=SITENUM_"-"_PSXBATNM
N DOMAIN,LCNT,XMDUZ,XMSUB,XMZ,ORD
S (LCNT,PSXMSGCT,PSXRXCT)=0
S X=$$KSP^XUPARAM("INST"),DIC="4",DIC(0)="MOXZ" D ^DIC S SITEX=$P(Y,"^",2),XMDUZ=.5 K X,Y,DIC
XMZ S XMSUB="CMOP Retransmission Update from "_SITEX
D XMZ^XMA2
I XMZ'>0 H 2 G XMZ
HDR ;Get header data
S ORD="$$RMIT"_U_PSXBATNM_U_PSXHDR_U_OLDBATNM D TXT
S PSXTYP=TRANI(17),PSXTDIV=TRANI(2)
S ORD=$G(PSXORD("A")) D TXT
S:$G(PSXORD("B",1))="" PSXORD("B",1)="NTE|2||"
S:$G(PSXORD("C",1))="" PSXORD("C",1)="NTE|3||"
S:$G(PSXORD("D",1))="" PSXORD("D",1)="NTE|4||"
F ZZ="B","C","D" S Z=0 F S Z=$O(PSXORD(ZZ,Z)) Q:Z'>0 S ORD=$G(PSXORD(ZZ,Z)) D TXT
MSG ;Get patient order data
S (LMSG,MSG)=0
F S MSG=$O(^PSX(550.1,"C",PSXBAT,MSG)) Q:MSG'>0 S:$G(MCT)'>0 MCT=MSG S LMSG=MSG,PSXMSGCT=PSXMSGCT+1,LNTX=+$P(^PSX(550.1,MSG,"T",0),U,4) D
.S ORD="$MSG^"_+$G(^PSX(550.1,MSG,0))_U_LNTX D TXT
.F PSX=1:1:LNTX I $G(^PSX(550.1,MSG,"T",PSX,0))]"" S ORD=$G(^(0)) S:$E(ORD,1,7)="ORC|NW|" PSXRXCT=PSXRXCT+1 D TXT
.S DA=MSG,DIE="^PSX(550.1,",DR="1///2;5////"_$H_";3////"_PSXBAT D ^DIE K DIE,DA,DR
.S REC=MSG,PSXRTRN=1 ;D SUSPS^PSXRXU
S ORD="$$ENDRMIT^"_U_U_PSXBATNM_U_PSXMSGCT_U_PSXRXCT D TXT K ORD
S ^XMB(3.9,XMZ,2,0)="^3.92A^"_LCNT_U_LCNT_U_DT,XMDUN="CMOP Manager"
S XMDUZ=.5
S RECV=$P($G(^PSX(550,+PSXSYS,0)),U,4),DOMAIN="@"_$$GET1^DIQ(4.2,RECV,.01)
;code to divert patient transmissions for testing
I '$D(^XTMP("PSXDIVERTCMOP")) S XMY("S.PSXX CMOP SERVER"_DOMAIN)="" I 1 ;****TESTING
E S XX=^XTMP("PSXDIVERTCMOP",1) S XMY(XX)="" H 1 ;****TESTING S.PSXX
D ENT1^XMD
K DIE,DA,DR,BAT,PSX,PSXORD
FILE L +^PSX(550.2,PSXBAT):30 G:'$T FILE
D NOW^%DTC S PSXTRDTM=%
S PSXLAST=LMSG,PSXFRST=MCT,DA=PSXBAT,DIE="^PSX(550.2,"
S DR="1////2;9////"_OLDBAT_";11////"_PSXFRST_";12////"_PSXLAST_";13////"_PSXMSGCT_";14////"_PSXRXCT_";5////"_PSXTRDTM D ^DIE
L -^PSX(550.2,PSXBAT) K DA,DIE
F1 L +^PSX(550.2,OLDBAT):30 G:'$T F1
S DA=OLDBAT,DIE="^PSX(550.2,",DR="1////5;8////"_PSXBAT D ^DIE
L -^PSX(550.2,OLDBAT) K DA,DIE
S PSXOLD=OLDBAT
D AFTER1^PSXRSYU ;set PSXBAT into 550
S PSXFLAG=1,PSXRTRN=1
D EN^PSXNOTE
S OLDBAT=PSXOLD
D START^PSXRXU ;update RXs in 52.5 & 52
D OERRCLR^PSXRSUS
S OLDBAT=PSXOLD
D SETSTAT^PSXRTRA1
D REPORT^PSXRTRA1
RESET S PSXSTAT="H" D PSXSTAT^PSXRSYU
G EXIT
Q
NO W !,"You are not authorized to use this option!" Q
EXIT S ZTREQ="@"
L -^PSX(550.1)
K PSXSTART,PSXEND,PSXRXCT,PSXMSGCT,PSXLAST,PSXSITE,PSXTDT,LASTBAT,LCNT,CNTX,MSG,REC,SITENUM,XQAMSG,XX,XMY,XMSUB,XMFROM,XMZ,XMDUZ,XMDUN,LNCT,OLDBAT,PSXMFLAG,FLAG,PSXSENDR,BMSG,EMSG,RECV,DOMAIN,CLOSED,PSXDIV,XSITE
K %,DIV,LNTX,SNDR,STATUS,TRNDT,Z,ZZ,PSXHDR,PSXJOB,PSXRTRN,PSXSTAT,PSXFRST,PSXBAT,PSXDUZ,PSXFLAG,DIR,Y,X,OLDSDT,S1,Y,DIRUT,DIROUT,DTOUT,DUOUT,BAD,MCT,LMSG,PSXOLD,PSXRXD
K ^PSX("CMOP TRANS"),PSXBATNM,OLDBATNM,TRAN,TRANI,PSXTRDTM,I
K ^TMP($J)
Q
CANMSG ; lock on 550.1 not achieved send transmission cancelled message
D CANMSG^PSXRTRA1
Q
TESTREL(RXDA,FILL) ; test release date, gather RX data, store for report
;returns SENT, "FILL '=", or Released Date
N DFN,VADM,SSN,RELDT,RELDTE,PATNM,REPLY,FILLX
S DFN=$$GET1^DIQ(52,RXDA,2,"I"),PATNM=$$GET1^DIQ(52,RXDA,2)
D DEM^VADPT S SSN=$P(VADM(2),U,2)
S RXNM=$P(^PSRX(RXDA,0),U)_"-"_FILL
I FILL=0 S RELDT=$P(^PSRX(RXDA,2),U,13)\1 I 1
E S RELDT=$P(^PSRX(RXDA,1,FILL,0),U,18)\1
S REPLY="SENT"
S:RELDT REPLY=$$FMTE^XLFDT(RELDT)
S FILLX=+$O(^PSRX(RXDA,1,"A"),-1) I FILL'=FILLX S REPLY="Fill '= "_FILLX
Q REPLY
NOTRAN ;no RXs passed testing to go into a new transmission
S XMSUB="Retransmission of "_OLDBATNM_" failed"
K TXT,XMY
S TXT(1,0)="No prescriptions passed testing to go into a new transmission"
S XMTEXT="TXT("
D GRP^PSXNOTE
D ^XMD
Q
SDT ;functional code as to SDT^PSXRPPL test and set individual RXs into 550.2
N SDT
S REC=$O(^PS(52.5,"B",RXDA,0)) Q:'REC
S XX=^PS(52.5,REC,0),SDT=$P(XX,U,2)
S XDFN=DFN
N RXN,RXDA,FILL
D GETDATA^PSXRPPL ;if RX is OK makes entry into new batch PSXBAT
D:$G(RXN) PSOUL^PSSLOCK(RXN),OERRLOCK^PSXRPPL(RXN)
Q
PSXRTRAN ;BIR/WPB/PDW-Batch Retransmission Routine ;13 Mar 2002 3:09 PM
+1 ;;2.0;CMOP;**18,27,31,41,51**;11 Apr 97
+2 ;Reference to ^PS(59, supported by DBIA #1976
+3 ;Reference to ^PS(59.7 supported by DBIA #694
+4 ;Reference to ^PSRX( supported by DBIA #1977
+5 ;
START IF '$DATA(^XUSEC("PSXCMOPMGR",DUZ))
DO NO
QUIT
+1 IF '$DATA(^XUSEC("PSXRTRAN",DUZ))
DO NO
QUIT
+2 IF '$DATA(^XUSEC("PSX XMIT",DUZ))
DO NO
QUIT
+3 DO SET^PSXSYS
+4 IF '$DATA(PSXSYS)
WRITE !,"CMOP processing is inactivated, re-transmission of data not allowed."
QUIT
+5 SET PSXJOB=2
+6 IF $DATA(^PSX(550,"TR","T"))
WRITE !,"There is another job in progress, try again later."
GOTO EXIT
+7 LOCK +PSX(550.1):3
IF '$TEST
WRITE !,"There is another job in progress, try again later."
GOTO EXIT
+8 IF '$DATA(^PSX(550.2,"AX"))
WRITE !!,"No data to re-transmit."
GOTO EXIT
+9 SET DIC="^PSX(550.2,"
SET DIC(0)="AMZEQ"
SET DIC("S")="I ($D(^PSX(550.2,""AX"",+Y))),($P($G(^PSX(550.2,+Y,1)),U,3)=""""),($P($G(^PSX(550.2,+Y,1)),U,1)="""")"
+10 DO ^DIC
KILL DIC,DIC("S"),DIC(0)
+11 IF $DATA(DTOUT)!($DATA(DUOUT))!($GET(Y)'>0)
GOTO EXIT
+12 SET OLDBAT=+Y
KILL Y,TRAN,TRANI
+13 ;external of fields
DO GETS^DIQ(550.2,OLDBAT,".01;2;3;5;14;17","","TRAN")
DO TOP^PSXUTL("TRAN")
+14 ;internal of fields
DO GETS^DIQ(550.2,OLDBAT,".01;2;3;5;14;17","I","TRANI")
DO TOP^PSXUTL("TRANI")
+15 SET OLDBATNM=TRAN(.01)
+16 WRITE !,"Transmission: "_TRAN(.01)
+17 WRITE !,"Date: "_TRAN(5)
+18 WRITE !,"Division: "_TRAN(2)
+19 WRITE !,"Type: "_TRAN(17)
+20 WRITE !,"CMOP Host: "_TRAN(3)
+21 WRITE !,"Total RXs: "_TRAN(14)
+22 SET TYP=$SELECT(TRANI(17)="C":"CS",1:"STD")
+23 SET PSXCS=$SELECT(TYP="CS":1,1:0)
DO SET^PSXSYS
+24 IF TRANI(3)'=+PSXSYS
WRITE !!,$$GET1^DIQ(550,+PSXSYS,.01)_" is the active host for transmitting "_TRAN(17)
GOTO EXIT
CLOSED SET CLOSED=$PIECE($GET(^PSX(550.2,OLDBAT,1)),U,1)
+1 IF CLOSED'=""
WRITE !,"The transmission selected has been acknowledged and cannot be re-transmitted."
DO RESET
GOTO EXIT
+2 IF $PIECE($GET(^PSX(550.2,OLDBAT,1)),U,2)'=""
WRITE !!,"This transmission has been re-transmitted once and cannot",!,"be retransmitted again."
DO RESET
GOTO ERRMSG^PSXERR1
+3 WRITE !!
+4 SET BMSG=$PIECE($GET(^PSX(550.2,OLDBAT,1)),U,5)-1
SET EMSG=$PIECE($GET(^PSX(550.2,OLDBAT,1)),U,6)
SET PSOSITE=$PIECE($GET(^PSX(550.2,OLDBAT,0)),"^",3)
+5 SET PSXSTART=BMSG+1
SET PSXDUZ=DUZ
SET PSXSITE=$PIECE($GET(PSXSYS),U,3)
+6 SET SNDR=$$GET1^DIQ(200,$PIECE($GET(^PSX(550.2,OLDBAT,0)),U,5),.01)
+7 SET DIV=$PIECE($GET(^PS(59,$PIECE($GET(^PSX(550.2,OLDBAT,0)),U,3),0)),U,1)
SET Y=$PIECE($GET(^PSX(550.2,OLDBAT,0)),U,6)
XECUTE ^DD("DD")
SET TRNDT=Y
+8 WRITE !," *** Coordinate re-transmissions with ",$$GET1^DIQ(550,+PSXSYS,.01)," CMOP ***",!
+9 SET DIR(0)="Y^O"
SET DIR("B")="NO"
SET DIR("A")="Are you sure you want to Re-transmit this batch"
DO ^DIR
KILL DIR
+10 IF Y=0!($DATA(DIRUT))
DO RESET
GOTO EXIT
QUE ;
+1 FOR YY="PSXMFLAG","BMSG","EMSG","PSXSYS","OLDBAT*","PSXDUZ","PSXJOB","PSXSITE","PSOSITE","PSXSTART","PSXJOB","PSXSITE","TRAN*","PSXCS"
SET ZTSAVE(YY)=""
+2 SET ZTDTH=$HOROLOG
SET ZTSAVE("ZZDATA")=""
SET ZTIO=""
SET ZTRTN="ENTRAN^PSXRTRAN"
SET ZTDESC="CMOP Retransmission"
+3 ;****TESTING
DO ^%ZTLOAD
+4 ;D ENTRAN S PSXSTAT="H" D PSXSTAT^PSXRSYU G EXIT ;****TESTING ;to run in the foreground uncomment this line and comment out the previous line
+5 IF $DATA(ZTSK)[0
WRITE !!,"Job Cancelled"
GOTO EXIT
+6 IF '$TEST
WRITE !!,"Re-transmission Queued "_ZTSK
+7 SET PSXSTAT="T"
DO PSXSTAT^PSXRSYU
+8 GOTO EXIT
TXT IF $GET(ORD)]""
SET LCNT=LCNT+1
SET ^XMB(3.9,XMZ,2,LCNT,0)=ORD
+1 QUIT
ENTRAN ;Entry for data transmission
LOCK ; >>>**** LOCK OF FILE 550.1 ****<<<
+1 FOR I=1:1:3
LOCK +^PSX(550.1):6
IF $TEST
SET I=100
+2 ; could not get a lock in 18 minutes of waiting
IF I'=100
DO CANMSG
GOTO EXIT
+3 KILL ^TMP($JOB,"PSX"),^TMP($JOB,"PSXDFN"),ZCNT,PSXBAT
+4 SET PSOPAR=^PS(59,PSOSITE,1)
+5 SET PSXTDIV=PSOSITE
SET PSXTYP=$SELECT(+$GET(PSXCS):"C",1:"N")
+6 SET PSOLAP=ION
SET PSOSYS=$GET(^PS(59.7,1,40.1))
SET PSXTRANS=1
SET PSXFLAG=1
+7 SET PSOINST=+$PIECE(PSXSYS,"^",2)
+8 SET PSXVENDR="AUTOMATED SYSTEM"
+9 SET PSXRTRAN=1
SET PSXRTRN=1
SET ZTREQ="@"
RESETRX ; pull, reset RXs from 550.2 RX multiple, if released do not send, make report
+1 KILL ^TMP($JOB,"PSXRTRAN"),LCNT
+2 SET PSXERFLG=0
SET PSXFLAG=1
SET PSXRTRAN=1
+3 FOR NI=1:1
IF '$DATA(^PSX(550.2,OLDBAT,15,NI,0))
QUIT
SET XX=^(0)
Begin DoDot:1
+4 NEW NI
+5 SET RXDA=$PIECE(XX,U,1)
SET FILL=$PIECE(XX,U,2)
SET DFN=$PIECE(XX,U,3)
SET REC=$PIECE(XX,U,5)
+6 ; test & catalog RXs for report, 'SENT' if OK, "FILL '=" if more recent fill, 'released date' if released
SET TEST=$$TESTREL(RXDA,FILL)
+7 IF TEST'="SENT"
QUIT
+8 ;RX pulled early from suspense
IF '$DATA(^PS(52.5,"B",RXDA))
QUIT
+9 DO RESET^PSXNEW(RXDA,FILL,"Re-Trans of "_OLDBAT)
+10 ;test/set RX into 550.2
DO SDT
End DoDot:1
+11 ;
+12 ;no RXs passed retesting
IF '$GET(PSXBAT)
DO NOTRAN
GOTO EXIT
+13 IF PSXERFLG=1
SET PSXJOB=7
DO ^PSXERR
+14 ; build 550.1 entries related to PSXBAT
DO EN^PSXBLD
+15 IF PSXERFLG=1
SET PFLAG=1
DO EN^PSXERR
+16 SET OLDSDT=$PIECE($GET(^PSX(550.2,OLDBAT,0)),"^",6)
+17 SET PSXSENDR=$$GET1^DIQ(200,PSXDUZ,.01)
SET (SITEN,SITENUM)=$PIECE($GET(PSXSYS),U,2)
SET PSXEND=EMSG
SET PSXDIV=$PIECE($GET(^PS(59,+PSOSITE,0)),U,1)
SET XSITE=$PIECE($GET(^PS(59,+PSOSITE,0)),U,6)
+18 SET PSXSTART=$ORDER(^PSX(550.1,"C",PSXBAT,0))
SET (PSXEND,EMSG)=$ORDER(^PSX(550.1,"C",PSXBAT,"A"),-1)
+19 SET PSXBATNM=$$GET1^DIQ(550.2,PSXBAT,.01)
+20 SET PSXHDR=PSXSITE_U_+PSXSYS_U_SITENUM_U_PSXTDT_U_PSXSENDR_U_PSXSTART_U_EMSG_U_PSXDIV_U_XSITE
SET PSXREF=SITENUM_"-"_PSXBATNM
+21 NEW DOMAIN,LCNT,XMDUZ,XMSUB,XMZ,ORD
+22 SET (LCNT,PSXMSGCT,PSXRXCT)=0
+23 SET X=$$KSP^XUPARAM("INST")
SET DIC="4"
SET DIC(0)="MOXZ"
DO ^DIC
SET SITEX=$PIECE(Y,"^",2)
SET XMDUZ=.5
KILL X,Y,DIC
XMZ SET XMSUB="CMOP Retransmission Update from "_SITEX
+1 DO XMZ^XMA2
+2 IF XMZ'>0
HANG 2
GOTO XMZ
HDR ;Get header data
+1 SET ORD="$$RMIT"_U_PSXBATNM_U_PSXHDR_U_OLDBATNM
DO TXT
+2 SET PSXTYP=TRANI(17)
SET PSXTDIV=TRANI(2)
+3 SET ORD=$GET(PSXORD("A"))
DO TXT
+4 IF $GET(PSXORD("B",1))=""
SET PSXORD("B",1)="NTE|2||"
+5 IF $GET(PSXORD("C",1))=""
SET PSXORD("C",1)="NTE|3||"
+6 IF $GET(PSXORD("D",1))=""
SET PSXORD("D",1)="NTE|4||"
+7 FOR ZZ="B","C","D"
SET Z=0
FOR
SET Z=$ORDER(PSXORD(ZZ,Z))
IF Z'>0
QUIT
SET ORD=$GET(PSXORD(ZZ,Z))
DO TXT
MSG ;Get patient order data
+1 SET (LMSG,MSG)=0
+2 FOR
SET MSG=$ORDER(^PSX(550.1,"C",PSXBAT,MSG))
IF MSG'>0
QUIT
IF $GET(MCT)'>0
SET MCT=MSG
SET LMSG=MSG
SET PSXMSGCT=PSXMSGCT+1
SET LNTX=+$PIECE(^PSX(550.1,MSG,"T",0),U,4)
Begin DoDot:1
+3 SET ORD="$MSG^"_+$GET(^PSX(550.1,MSG,0))_U_LNTX
DO TXT
+4 FOR PSX=1:1:LNTX
IF $GET(^PSX(550.1,MSG,"T",PSX,0))]""
SET ORD=$GET(^(0))
IF $EXTRACT(ORD,1,7)="ORC|NW|"
SET PSXRXCT=PSXRXCT+1
DO TXT
+5 SET DA=MSG
SET DIE="^PSX(550.1,"
SET DR="1///2;5////"_$HOROLOG_";3////"_PSXBAT
DO ^DIE
KILL DIE,DA,DR
+6 ;D SUSPS^PSXRXU
SET REC=MSG
SET PSXRTRN=1
End DoDot:1
+7 SET ORD="$$ENDRMIT^"_U_U_PSXBATNM_U_PSXMSGCT_U_PSXRXCT
DO TXT
KILL ORD
+8 SET ^XMB(3.9,XMZ,2,0)="^3.92A^"_LCNT_U_LCNT_U_DT
SET XMDUN="CMOP Manager"
+9 SET XMDUZ=.5
+10 SET RECV=$PIECE($GET(^PSX(550,+PSXSYS,0)),U,4)
SET DOMAIN="@"_$$GET1^DIQ(4.2,RECV,.01)
+11 ;code to divert patient transmissions for testing
+12 ;****TESTING
IF '$DATA(^XTMP("PSXDIVERTCMOP"))
SET XMY("S.PSXX CMOP SERVER"_DOMAIN)=""
IF 1
+13 ;****TESTING S.PSXX
IF '$TEST
SET XX=^XTMP("PSXDIVERTCMOP",1)
SET XMY(XX)=""
HANG 1
+14 DO ENT1^XMD
+15 KILL DIE,DA,DR,BAT,PSX,PSXORD
FILE LOCK +^PSX(550.2,PSXBAT):30
IF '$TEST
GOTO FILE
+1 DO NOW^%DTC
SET PSXTRDTM=%
+2 SET PSXLAST=LMSG
SET PSXFRST=MCT
SET DA=PSXBAT
SET DIE="^PSX(550.2,"
+3 SET DR="1////2;9////"_OLDBAT_";11////"_PSXFRST_";12////"_PSXLAST_";13////"_PSXMSGCT_";14////"_PSXRXCT_";5////"_PSXTRDTM
DO ^DIE
+4 LOCK -^PSX(550.2,PSXBAT)
KILL DA,DIE
F1 LOCK +^PSX(550.2,OLDBAT):30
IF '$TEST
GOTO F1
+1 SET DA=OLDBAT
SET DIE="^PSX(550.2,"
SET DR="1////5;8////"_PSXBAT
DO ^DIE
+2 LOCK -^PSX(550.2,OLDBAT)
KILL DA,DIE
+3 SET PSXOLD=OLDBAT
+4 ;set PSXBAT into 550
DO AFTER1^PSXRSYU
+5 SET PSXFLAG=1
SET PSXRTRN=1
+6 DO EN^PSXNOTE
+7 SET OLDBAT=PSXOLD
+8 ;update RXs in 52.5 & 52
DO START^PSXRXU
+9 DO OERRCLR^PSXRSUS
+10 SET OLDBAT=PSXOLD
+11 DO SETSTAT^PSXRTRA1
+12 DO REPORT^PSXRTRA1
RESET SET PSXSTAT="H"
DO PSXSTAT^PSXRSYU
+1 GOTO EXIT
+2 QUIT
NO WRITE !,"You are not authorized to use this option!"
QUIT
EXIT SET ZTREQ="@"
+1 LOCK -^PSX(550.1)
+2 KILL PSXSTART,PSXEND,PSXRXCT,PSXMSGCT,PSXLAST,PSXSITE,PSXTDT,LASTBAT,LCNT,CNTX,MSG,REC,SITENUM,XQAMSG,XX,XMY,XMSUB,XMFROM,XMZ,XMDUZ,XMDUN,LNCT,OLDBAT,PSXMFLAG,FLAG,PSXSENDR,BMSG,EMSG,RECV,DOMAIN,CLOSED,PSXDIV,XSITE
+3 KILL %,DIV,LNTX,SNDR,STATUS,TRNDT,Z,ZZ,PSXHDR,PSXJOB,PSXRTRN,PSXSTAT,PSXFRST,PSXBAT,PSXDUZ,PSXFLAG,DIR,Y,X,OLDSDT,S1,Y,DIRUT,DIROUT,DTOUT,DUOUT,BAD,MCT,LMSG,PSXOLD,PSXRXD
+4 KILL ^PSX("CMOP TRANS"),PSXBATNM,OLDBATNM,TRAN,TRANI,PSXTRDTM,I
+5 KILL ^TMP($JOB)
+6 QUIT
CANMSG ; lock on 550.1 not achieved send transmission cancelled message
+1 DO CANMSG^PSXRTRA1
+2 QUIT
TESTREL(RXDA,FILL) ; test release date, gather RX data, store for report
+1 ;returns SENT, "FILL '=", or Released Date
+2 NEW DFN,VADM,SSN,RELDT,RELDTE,PATNM,REPLY,FILLX
+3 SET DFN=$$GET1^DIQ(52,RXDA,2,"I")
SET PATNM=$$GET1^DIQ(52,RXDA,2)
+4 DO DEM^VADPT
SET SSN=$PIECE(VADM(2),U,2)
+5 SET RXNM=$PIECE(^PSRX(RXDA,0),U)_"-"_FILL
+6 IF FILL=0
SET RELDT=$PIECE(^PSRX(RXDA,2),U,13)\1
IF 1
+7 IF '$TEST
SET RELDT=$PIECE(^PSRX(RXDA,1,FILL,0),U,18)\1
+8 SET REPLY="SENT"
+9 IF RELDT
SET REPLY=$$FMTE^XLFDT(RELDT)
+10 SET FILLX=+$ORDER(^PSRX(RXDA,1,"A"),-1)
IF FILL'=FILLX
SET REPLY="Fill '= "_FILLX
+11 QUIT REPLY
NOTRAN ;no RXs passed testing to go into a new transmission
+1 SET XMSUB="Retransmission of "_OLDBATNM_" failed"
+2 KILL TXT,XMY
+3 SET TXT(1,0)="No prescriptions passed testing to go into a new transmission"
+4 SET XMTEXT="TXT("
+5 DO GRP^PSXNOTE
+6 DO ^XMD
+7 QUIT
SDT ;functional code as to SDT^PSXRPPL test and set individual RXs into 550.2
+1 NEW SDT
+2 SET REC=$ORDER(^PS(52.5,"B",RXDA,0))
IF 'REC
QUIT
+3 SET XX=^PS(52.5,REC,0)
SET SDT=$PIECE(XX,U,2)
+4 SET XDFN=DFN
+5 NEW RXN,RXDA,FILL
+6 ;if RX is OK makes entry into new batch PSXBAT
DO GETDATA^PSXRPPL
+7 IF $GET(RXN)
DO PSOUL^PSSLOCK(RXN)
DO OERRLOCK^PSXRPPL(RXN)
+8 QUIT
