- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXRTRAN 8956 printed Jan 18, 2025@02:46:21 Page 2
- 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