source: WorldVistAEHR/trunk/r/CMOP-PSX/PSXRECV1.m@ 1679

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

initial load of WorldVistAEHR

File size: 5.7 KB
Line 
1PSXRECV1 ;BIR/WPB-Downloads Data from Mailman Msg to Files-CONTINUED ;04/08/97 2:06 PM
2 ;;2.0;CMOP;**34,38,45**;11 Apr 97
3CHKDUP S FLAG5=0,OLDTM=$P(^PSX(552.1,SAME,0),"^",4)
4 ;if status=1 and trans dt/tm not same ! first msg # not same ! last
5 ;msg # not same leave old download new and put both on hold
6 I $P($G(^PSX(552.1,SAME,0)),"^",2)=1&($G(SDATE)'=$P($G(^PSX(552.1,SAME,0)),"^",3))!(($G(PSXSTART)'=$P($G(^PSX(552.1,SAME,1)),"^",1))!($G(PSXLAST)'=$P($G(^PSX(552.1,SAME,1)),"^",2))) S FLAG5=0 Q
7 ;deletes the old transmission from 512,515,514 and downloads new trans
8 I $P($G(^PSX(552.1,SAME,0)),"^",2)=1&(($G(PSXSTART)=$P($G(^PSX(552.1,SAME,1)),"^",1))!($G(PSXLAST)=$P($G(^PSX(552.1,SAME,1)),"^",2))) S FLAG5=0 D CLNUP Q
9 ;if status>2 don't download new
10 I $P($G(^PSX(552.1,SAME,0)),"^",2)>1 S FLAG5=1 Q
11 Q
12CLNUP S P515=$O(^PSX(552.4,"B",SAME,"")) Q:$G(SAME)="" S DA=P515,DIK="^PSX(552.4," D ^DIK K DA,DIK,P515
13 S BAT=$P($G(^PSX(552.1,SAME,0)),"^"),DIK="^PSX(552.2,"
14 S I512=0 F S I512=$O(^PSX(552.2,"AQ",BAT,I512)) Q:I512'>0 S DA=I512 D ^DIK K DA
15 K DIK,DA,BAT,I512
16 S DA=SAME,DIK="^PSX(552.1," D ^DIK K DA,DIK
17 S SAME="",PSXRTRN=0
18 Q
19F515 ;
20 ; test if VA and RX already filed
21 I '$D(^PSX(552,"D",+PSXREF)) Q:$D(^PSX(552.4,DA515,1,"B",RX515))
22 ; adjustment made to allow DOD multiple different fills for the same RX
23 I $D(^PSX(552.4,DA515,1,"B",RX515)) N DA55241,FILL D I FILL=FL515 Q
24 . S DA55241=0
25 . F S DA55241=$O(^PSX(552.4,DA515,1,"B",RX515,DA55241)) Q:DA55241'>0 S FILL=$P(^PSX(552.4,DA515,1,DA55241,0),U,12) Q:FILL=FL515
26 S XYZ=" "
27 S MCT=$G(MCT)+1
28 I $G(MCT)=1 D
29 .S Y=SDATE X ^DD("DD")
30 .S ^TMP($J,"PSXREV",1)=PSXSITE_" "_PSXREF_" TRANSMITTED: "_Y K Y
31 .S (^TMP($J,"PSXREV",2),^TMP($J,"PSXREV",4))=""
32 .S ^TMP($J,"PSXREV",3)="ORD# PATIENT RX# FILL DRUG NAME"
33 .S $P(^TMP($J,"PSXREV",4),"-",79)="-"
34 S ZFILL=$S(FL515>0:"REF"_FL515,1:"ORIG")
35 S ^TMP($J,"PSXREV",MCT+4)=$S(NAME'=$G(NAME1):PSXMSG_$E(XYZ,1,5-$L(PSXMSG))_$E(NAME,1,18)_$S($L(NAME)>18:" ",1:$E(XYZ,1,19-$L(NAME))),1:XYZ)_RX515_$E(XYZ,1,15-$L(RX515))_(ZFILL)_$E(XYZ,1,6-$L((ZFILL)))_$E(PSXDRG,1,32),NAME1=NAME
36 K DD,DO
37 S:'$D(^PSX(552.4,DA515,1,0)) ^PSX(552.4,DA515,1,0)="^552.41A^^"
38FF S DA(1)=DA515,X=RX515,DIC(0)="Z",DIC="^PSX(552.4,"_DA515_",1,"
39 S DIC("DR")="3////"_DRG515_";9////5;11////"_FL515_";12////"_QTY515_";19////"_PSXCS_";21////"_PSXMSG_";40///^S X=RXNDX"
40 D FILE^DICN
41 K DIC,DA,X,DRG515,FL515,RX515,QTY515,DIC("DR"),PSXCS
42 Q
43UPDATE D NOW^%DTC S PSXFTDT=%,PSXFLG1=0
44 L +^PSX(552.1,OLDDA):600 G:'$T EXIT S $P(^PSX(552.1,OLDDA,0),"^",2)=$S(PSXRTRN<1:"2",PSXRTRN>0:"5",1:"")
45 S DA=OLDDA,DIE="^PSX(552.1,",DR="10////"_PSXORDCT_";11////"_PSXRXS D ^DIE K DIE,DA L -^PSX(552.1,OLDDA) I PSXRTRN>0 K ^PSX(552.1,"AQ",PSXFTDT,PSXREF,OLDDA)
46 I PSXRTRN=2 L +^PSX(552.1,SAME):600 G:'T EXIT S $P(^PSX(552.1,SAME,0),"^",2)=5 L -^PSX(552.1,SAME) K ^PSX(552.1,"AQ",$P(^PSX(552.1,SAME,0),"^",4),PSXREF,SAME)
47 I PSXRTRN=2 S FL1=$P($G(^PSX(552.1,SAME,0)),"^",2) S:$G(FL1)=3 PSXFLG1=1
48 S PSXRXCT=$P(XMRG,U,6),PSXMSGCT=$P(XMRG,U,5),PSXEND=PSXMSG,SDT=$P(SDATE,".",1)
49 S %H=$H D YX^%DTC S PSXTDT=Y K %H
50 S:(PSXRTRN=0)!(PSXRTRN=2)!(PSXRTRN=3) PSXFLAG=2
51 S:PSXRTRN=1 PSXFLAG=4
52 D EN^PSXNOTE
53 ;S PSXRECV=1 D ACK^PSXNOTE
54 ;I (PSXRTRN=1),($G(PSXJOB)=2) D ^PSXERR
55 F RR=0:0 S RR=$O(^PSX(552,"B",+SITENUM,RR)) Q:RR'>0 S REC=RR
56 L +^PSX(552,$G(REC)):30 G:'$T EXIT
57 S DA=REC,DIE="^PSX(552,",DR="3////"_PSXBAT D ^DIE K DIE,DA,DR
58 L -^PSX(552,$G(REC))
59 N XMZ,XMSUB,XMDUN,XMDUZ,XMY
60 S XMSUB="CMOP Review # "_PSXREF_", "_PSXDIV,XMDUZ=.5
61XMZ D XMZ^XMA2
62 I XMZ'>0 G XMZ
63 F I=0:0 S I=$O(^TMP($J,"PSXREV",I)) Q:'I S ZCNT=I,^XMB(3.9,XMZ,2,I,0)=^TMP($J,"PSXREV",I)
64 S ^XMB(3.9,XMZ,2,0)="^3.92A^"_ZCNT_U_ZCNT_U_DT,XMDUN="CMOP Manager",XMDUZ=.5
65 D GRP^PSXNOTE,ENT1^XMD
66 K PSXFLG1,FL1,ZCNT
67 I $G(OLDDA)'="" S DA=OLDDA,DIK="^PSX(552.1," D IX^DIK K DA,DIK
68 I $G(SAME)'="" S DA=SAME,DIK="^PSX(552.1," D IX^DIK K DIK,DA
69CHECK ;this would be a good place for an alert to be sent
70 I '$D(^PSX(552,"D",SITEN)) I (PSXSMSG'=PSXSTART)!(PSXLAST'=PSXMSG)!(PSXORDCT'=PSXMSGCT)!(PSXRXS'=PSXRXCT) D ERR^PSXNOTE,HOLD
71 L +^PSX(552.1,OLDDA):600 G:'$T EXIT
72 S DA=OLDDA,DIE="^PSX(552.1,",DR="6////"_PSXFTDT D ^DIE K DIE,DA
73 L -^PSX(552.1,OLDDA)
74 S DIK="^PSX(552.1,",DA=OLDDA D IX^DIK K DA,DIK
75DOD ; DOD interface - send ACK even if placed in hold
76 S BATID=$$GET1^DIQ(552.1,OLDDA,.01),AGNCYID=$P(BATID,"-",1)
77 ;non DoD send batch acknowledgement and quit
78 I '$D(^PSX(552,"D",AGNCYID)) S PSXRECV=1 D ACK^PSXNOTE K PSXRECV Q
79 ; DoD send acknowledgement
80 S BATID=$E(BATID,2,999) ;****institution leading 1 remove
81 K ACK
82 S ACK="MSH|^~\&|VistA||CHCS||20010925202704||ORM^O02|573-013240530|P|2.3.1|||NE|NE"
83 D NOW^%DTC S BATDTM=+$$HLDATE^HLFNC(%)
84 F YY="BATID^10","BATDTM^7" D PUT(.ACK,"|",YY)
85 S ACK(1)=ACK,ACK(2)="MSA|CA|"_BATID
86 S FNAME2=$TR(BATID,"-","_")_".TAC",PATH=$$GET1^DIQ(554,1,21)
87 F XX=1:1:5 S Y=$$GTF^%ZISH("ACK(1)",1,PATH,FNAME2) Q:Y=1 H 4
88 I Y'=1 S GBL="ACK" D FALERT^PSXDODNT(FNAME2,PATH,GBL)
89 S PATH=$$GET1^DIQ(554,1,22)
90 F XX=1:1:5 S Y=$$GTF^%ZISH("ACK(1)",1,PATH,FNAME2) Q:Y=1 H 4
91 I Y'=1 S GBL="ACK" D FALERT^PSXDODNT(FNAME2,PATH,GBL)
92 Q
93HOLD L +^PSX(552.1,OLDDA):600 G:'$T EXIT S $P(^PSX(552.1,OLDDA,0),"^",2)=5 L -^PSX(552.1,OLDDA)
94 Q
95EXIT K PSXSTART,PSXEND,PSXRXCT,PSXMSGCT,PSXSMSG,PSXLAST,PSXRXS,PSXORDCT,PSXSITE,PSXTDT,PSXFTDT,%,DOMAIN,PSXFLAG,I,OLDDA,PSXID,PSXSENDR,PSXREF,PSXMSG,PSXBAT,SDATE,SDT,SUBDA,PSXSYST,X,Y,XMFROM,SITENUM
96 K XMSER,XQMSG,XQSOP,OLDBAT,XMZ,PSXDIV,XSITE,CHK,REC,RR,RRR,SITEN,PSXJOB,PSXERR,PSXFROM,PSXOLD,PSXRTRN,XX,NAME,PSXDRG,NAME1,^TMP($J,"PSXREV"),XYZ,MCT,PSXRECV
97 K RXNDX
98 Q
99PIECE(REC,DLM,XX) ;
100 ; Set variable V = piece P of REC using delimiter DLM
101 N V,P S V=$P(XX,U),P=$P(XX,U,2),@V=$P(REC,DLM,P)
102 Q
103PUT(REC,DLM,XX) ;
104 ; Set Variable V into piece P of REC using delimiter DLM
105 N V,P S V=$P(XX,U),P=$P(XX,U,2)
106 S $P(REC,DLM,P)=$G(@V)
107 Q
Note: See TracBrowser for help on using the repository browser.