Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSXRTRAN

PSXRTRAN.m

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