source: FOIAVistA/trunk/r/CMOP-PSX/PSXRTRAN.m@ 1446

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

initial load of FOIAVistA 6/30/08 version
File size: 8.6 KB
Line 
1PSXRTRAN ;BIR/WPB/PDW-Batch Retransmission Routine ;13 Mar 2002 3:09 PM
2 ;;2.0;CMOP;**18,27,31,41,51**;11 Apr 97
3 ;Reference to ^PS(59, supported by DBIA #1976
4 ;Reference to ^PS(59.7 supported by DBIA #694
5 ;Reference to ^PSRX( supported by DBIA #1977
6 ;
7START I '$D(^XUSEC("PSXCMOPMGR",DUZ)) D NO Q
8 I '$D(^XUSEC("PSXRTRAN",DUZ)) D NO Q
9 I '$D(^XUSEC("PSX XMIT",DUZ)) D NO Q
10 D SET^PSXSYS
11 I '$D(PSXSYS) W !,"CMOP processing is inactivated, re-transmission of data not allowed." Q
12 S PSXJOB=2
13 I $D(^PSX(550,"TR","T")) W !,"There is another job in progress, try again later." G EXIT
14 L +PSX(550.1):3 I '$T W !,"There is another job in progress, try again later." G EXIT
15 I '$D(^PSX(550.2,"AX")) W !!,"No data to re-transmit." G EXIT
16 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)="""")"
17 D ^DIC K DIC,DIC("S"),DIC(0)
18 G:$D(DTOUT)!($D(DUOUT))!($G(Y)'>0) EXIT
19 S OLDBAT=+Y K Y,TRAN,TRANI
20 D GETS^DIQ(550.2,OLDBAT,".01;2;3;5;14;17","","TRAN"),TOP^PSXUTL("TRAN") ;external of fields
21 D GETS^DIQ(550.2,OLDBAT,".01;2;3;5;14;17","I","TRANI"),TOP^PSXUTL("TRANI") ;internal of fields
22 S OLDBATNM=TRAN(.01)
23 W !,"Transmission: "_TRAN(.01)
24 W !,"Date: "_TRAN(5)
25 W !,"Division: "_TRAN(2)
26 W !,"Type: "_TRAN(17)
27 W !,"CMOP Host: "_TRAN(3)
28 W !,"Total RXs: "_TRAN(14)
29 S TYP=$S(TRANI(17)="C":"CS",1:"STD")
30 S PSXCS=$S(TYP="CS":1,1:0) D SET^PSXSYS
31 I TRANI(3)'=+PSXSYS W !!,$$GET1^DIQ(550,+PSXSYS,.01)_" is the active host for transmitting "_TRAN(17) G EXIT
32CLOSED S CLOSED=$P($G(^PSX(550.2,OLDBAT,1)),U,1)
33 I CLOSED'="" W !,"The transmission selected has been acknowledged and cannot be re-transmitted." D RESET G EXIT
34 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
35 W !!
36 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)
37 S PSXSTART=BMSG+1,PSXDUZ=DUZ,PSXSITE=$P($G(PSXSYS),U,3)
38 S SNDR=$$GET1^DIQ(200,$P($G(^PSX(550.2,OLDBAT,0)),U,5),.01)
39 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
40 W !," *** Coordinate re-transmissions with ",$$GET1^DIQ(550,+PSXSYS,.01)," CMOP ***",!
41 S DIR(0)="Y^O",DIR("B")="NO",DIR("A")="Are you sure you want to Re-transmit this batch" D ^DIR K DIR
42 I Y=0!($D(DIRUT)) D RESET G EXIT
43QUE ;
44 F YY="PSXMFLAG","BMSG","EMSG","PSXSYS","OLDBAT*","PSXDUZ","PSXJOB","PSXSITE","PSOSITE","PSXSTART","PSXJOB","PSXSITE","TRAN*","PSXCS" S ZTSAVE(YY)=""
45 S ZTDTH=$H,ZTSAVE("ZZDATA")="",ZTIO="",ZTRTN="ENTRAN^PSXRTRAN",ZTDESC="CMOP Retransmission"
46 D ^%ZTLOAD ;****TESTING
47 ;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
48 I $D(ZTSK)[0 W !!,"Job Cancelled" G EXIT
49 E W !!,"Re-transmission Queued "_ZTSK
50 S PSXSTAT="T" D PSXSTAT^PSXRSYU
51 G EXIT
52TXT I $G(ORD)]"" S LCNT=LCNT+1,^XMB(3.9,XMZ,2,LCNT,0)=ORD
53 Q
54ENTRAN ;Entry for data transmission
55LOCK ; >>>**** LOCK OF FILE 550.1 ****<<<
56 F I=1:1:3 L +^PSX(550.1):6 I $T S I=100
57 I I'=100 D CANMSG G EXIT ; could not get a lock in 18 minutes of waiting
58 K ^TMP($J,"PSX"),^TMP($J,"PSXDFN"),ZCNT,PSXBAT
59 S PSOPAR=^PS(59,PSOSITE,1)
60 S PSXTDIV=PSOSITE,PSXTYP=$S(+$G(PSXCS):"C",1:"N")
61 S PSOLAP=ION,PSOSYS=$G(^PS(59.7,1,40.1)),PSXTRANS=1,PSXFLAG=1
62 S PSOINST=+$P(PSXSYS,"^",2)
63 S PSXVENDR="AUTOMATED SYSTEM"
64 S PSXRTRAN=1,PSXRTRN=1,ZTREQ="@"
65RESETRX ; pull, reset RXs from 550.2 RX multiple, if released do not send, make report
66 K ^TMP($J,"PSXRTRAN"),LCNT
67 S PSXERFLG=0 S PSXFLAG=1,PSXRTRAN=1
68 F NI=1:1 Q:'$D(^PSX(550.2,OLDBAT,15,NI,0)) S XX=^(0) D
69 . N NI
70 . S RXDA=$P(XX,U,1),FILL=$P(XX,U,2),DFN=$P(XX,U,3),REC=$P(XX,U,5)
71 . S TEST=$$TESTREL(RXDA,FILL) ; test & catalog RXs for report, 'SENT' if OK, "FILL '=" if more recent fill, 'released date' if released
72 . Q:TEST'="SENT"
73 . Q:'$D(^PS(52.5,"B",RXDA)) ;RX pulled early from suspense
74 . D RESET^PSXNEW(RXDA,FILL,"Re-Trans of "_OLDBAT)
75 . D SDT ;test/set RX into 550.2
76 ;
77 I '$G(PSXBAT) D NOTRAN G EXIT ;no RXs passed retesting
78 I PSXERFLG=1 S PSXJOB=7 D ^PSXERR
79 D EN^PSXBLD ; build 550.1 entries related to PSXBAT
80 I PSXERFLG=1 S PFLAG=1 D EN^PSXERR
81 S OLDSDT=$P($G(^PSX(550.2,OLDBAT,0)),"^",6)
82 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)
83 S PSXSTART=$O(^PSX(550.1,"C",PSXBAT,0)),(PSXEND,EMSG)=$O(^PSX(550.1,"C",PSXBAT,"A"),-1)
84 S PSXBATNM=$$GET1^DIQ(550.2,PSXBAT,.01)
85 S PSXHDR=PSXSITE_U_+PSXSYS_U_SITENUM_U_PSXTDT_U_PSXSENDR_U_PSXSTART_U_EMSG_U_PSXDIV_U_XSITE,PSXREF=SITENUM_"-"_PSXBATNM
86 N DOMAIN,LCNT,XMDUZ,XMSUB,XMZ,ORD
87 S (LCNT,PSXMSGCT,PSXRXCT)=0
88 S X=$$KSP^XUPARAM("INST"),DIC="4",DIC(0)="MOXZ" D ^DIC S SITEX=$P(Y,"^",2),XMDUZ=.5 K X,Y,DIC
89XMZ S XMSUB="CMOP Retransmission Update from "_SITEX
90 D XMZ^XMA2
91 I XMZ'>0 H 2 G XMZ
92HDR ;Get header data
93 S ORD="$$RMIT"_U_PSXBATNM_U_PSXHDR_U_OLDBATNM D TXT
94 S PSXTYP=TRANI(17),PSXTDIV=TRANI(2)
95 S ORD=$G(PSXORD("A")) D TXT
96 S:$G(PSXORD("B",1))="" PSXORD("B",1)="NTE|2||"
97 S:$G(PSXORD("C",1))="" PSXORD("C",1)="NTE|3||"
98 S:$G(PSXORD("D",1))="" PSXORD("D",1)="NTE|4||"
99 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
100MSG ;Get patient order data
101 S (LMSG,MSG)=0
102 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
103 .S ORD="$MSG^"_+$G(^PSX(550.1,MSG,0))_U_LNTX D TXT
104 .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
105 .S DA=MSG,DIE="^PSX(550.1,",DR="1///2;5////"_$H_";3////"_PSXBAT D ^DIE K DIE,DA,DR
106 .S REC=MSG,PSXRTRN=1 ;D SUSPS^PSXRXU
107 S ORD="$$ENDRMIT^"_U_U_PSXBATNM_U_PSXMSGCT_U_PSXRXCT D TXT K ORD
108 S ^XMB(3.9,XMZ,2,0)="^3.92A^"_LCNT_U_LCNT_U_DT,XMDUN="CMOP Manager"
109 S XMDUZ=.5
110 S RECV=$P($G(^PSX(550,+PSXSYS,0)),U,4),DOMAIN="@"_$$GET1^DIQ(4.2,RECV,.01)
111 ;code to divert patient transmissions for testing
112 I '$D(^XTMP("PSXDIVERTCMOP")) S XMY("S.PSXX CMOP SERVER"_DOMAIN)="" I 1 ;****TESTING
113 E S XX=^XTMP("PSXDIVERTCMOP",1) S XMY(XX)="" H 1 ;****TESTING S.PSXX
114 D ENT1^XMD
115 K DIE,DA,DR,BAT,PSX,PSXORD
116FILE L +^PSX(550.2,PSXBAT):30 G:'$T FILE
117 D NOW^%DTC S PSXTRDTM=%
118 S PSXLAST=LMSG,PSXFRST=MCT,DA=PSXBAT,DIE="^PSX(550.2,"
119 S DR="1////2;9////"_OLDBAT_";11////"_PSXFRST_";12////"_PSXLAST_";13////"_PSXMSGCT_";14////"_PSXRXCT_";5////"_PSXTRDTM D ^DIE
120 L -^PSX(550.2,PSXBAT) K DA,DIE
121F1 L +^PSX(550.2,OLDBAT):30 G:'$T F1
122 S DA=OLDBAT,DIE="^PSX(550.2,",DR="1////5;8////"_PSXBAT D ^DIE
123 L -^PSX(550.2,OLDBAT) K DA,DIE
124 S PSXOLD=OLDBAT
125 D AFTER1^PSXRSYU ;set PSXBAT into 550
126 S PSXFLAG=1,PSXRTRN=1
127 D EN^PSXNOTE
128 S OLDBAT=PSXOLD
129 D START^PSXRXU ;update RXs in 52.5 & 52
130 D OERRCLR^PSXRSUS
131 S OLDBAT=PSXOLD
132 D SETSTAT^PSXRTRA1
133 D REPORT^PSXRTRA1
134RESET S PSXSTAT="H" D PSXSTAT^PSXRSYU
135 G EXIT
136 Q
137NO W !,"You are not authorized to use this option!" Q
138EXIT S ZTREQ="@"
139 L -^PSX(550.1)
140 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
141 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
142 K ^PSX("CMOP TRANS"),PSXBATNM,OLDBATNM,TRAN,TRANI,PSXTRDTM,I
143 K ^TMP($J)
144 Q
145CANMSG ; lock on 550.1 not achieved send transmission cancelled message
146 D CANMSG^PSXRTRA1
147 Q
148TESTREL(RXDA,FILL) ; test release date, gather RX data, store for report
149 ;returns SENT, "FILL '=", or Released Date
150 N DFN,VADM,SSN,RELDT,RELDTE,PATNM,REPLY,FILLX
151 S DFN=$$GET1^DIQ(52,RXDA,2,"I"),PATNM=$$GET1^DIQ(52,RXDA,2)
152 D DEM^VADPT S SSN=$P(VADM(2),U,2)
153 S RXNM=$P(^PSRX(RXDA,0),U)_"-"_FILL
154 I FILL=0 S RELDT=$P(^PSRX(RXDA,2),U,13)\1 I 1
155 E S RELDT=$P(^PSRX(RXDA,1,FILL,0),U,18)\1
156 S REPLY="SENT"
157 S:RELDT REPLY=$$FMTE^XLFDT(RELDT)
158 S FILLX=+$O(^PSRX(RXDA,1,"A"),-1) I FILL'=FILLX S REPLY="Fill '= "_FILLX
159 Q REPLY
160NOTRAN ;no RXs passed testing to go into a new transmission
161 S XMSUB="Retransmission of "_OLDBATNM_" failed"
162 K TXT,XMY
163 S TXT(1,0)="No prescriptions passed testing to go into a new transmission"
164 S XMTEXT="TXT("
165 D GRP^PSXNOTE
166 D ^XMD
167 Q
168SDT ;functional code as to SDT^PSXRPPL test and set individual RXs into 550.2
169 N SDT
170 S REC=$O(^PS(52.5,"B",RXDA,0)) Q:'REC
171 S XX=^PS(52.5,REC,0),SDT=$P(XX,U,2)
172 S XDFN=DFN
173 N RXN,RXDA,FILL
174 D GETDATA^PSXRPPL ;if RX is OK makes entry into new batch PSXBAT
175 D:$G(RXN) PSOUL^PSSLOCK(RXN),OERRLOCK^PSXRPPL(RXN)
176 Q
Note: See TracBrowser for help on using the repository browser.