source: FOIAVistA/trunk/r/CMOP-PSX/PSXRTN1.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 5.3 KB
Line 
1PSXRTN1 ;BIR/WPB,HTW-Background filer for V2 ;MAR 1,2002@16:11:17
2 ;;2.0;CMOP;**1,2,14,23,32**;11 Apr 97
3 ;Reference to ^PSDRUG( supported by DBIA #1983
4DATA ;gets the data from PSX(513
5 S PSXZTSK=ZTSK
6 S R554=$O(^PSX(554,"AB",""))
7 I $P($G(^PSX(554,1,1,R554,0)),U,4)="R" D NEXT^PSXRTN Q
8 S $P(^PSX(554,1,1,R554,0),U,4)="R"
9EN K ^TMP($J,"PSXCAN"),XX0,ZZ,REC,TNODE
10 S X=$$FMADD^XLFDT(DT,+7),^XTMP("PSXBAD "_DT,0)=X_U_DT_U_"Vendor Missing NTE|100 segments"
11 S (CANFLG,STOP,ZMPFLG)=0
12 S LSTQRY=$O(^PSX(553.2,"A"),-1)
13 S XX0=0 F S XX0=$O(^PSX(552.3,"AQ",XX0)) Q:XX0'>0 G:STOP>0 FIN S TNODE=$G(^PSX(552.3,XX0,0)) S XX1=XX0+1 D
14 .I $E(TNODE,1,7)["NTE|100" S DA=XX0,DR="1////1",DIE="^PSX(552.3," D ^DIE K DIE,DA,DR Q
15 .I $E(TNODE,1,4)["PID|" S DA=XX0,DIE="^PSX(552.3,",DR="1////1" D ^DIE K DA,DR,DIE Q
16 .I $E(TNODE,1,4)["MSA|" S QRYN=$P(TNODE,"|",3),DA=XX0,DR="1////1",DIE="^PSX(552.3," D ^DIE K DA,DIE,DR D Q
17 ..I $G(QRYN)>0 S:($G(QRYN)=LSTQRY)&($P(^PSX(553.1,QRYN,0),"^",5)'=1) STOP=1
18 .Q:$G(STOP)>0
19 .S:$G(QRYN)'>0 QRYN=LSTQRY-1
20 .I $E(TNODE,1,3)["BTS" S DA=XX0,DR="1////1",DIE="^PSX(552.3," D ^DIE K DA,DR,DIE,QRYD Q
21 .I $E(TNODE,1,4)["QRD|" S PSXTS=$P(TNODE,"|",2),QRYN=$P(TNODE,"|",5) D TSIN^PSXUTL L +^PSX(553.1,QRYN):30 S QRYD=XX0,DA=QRYN,DIE="^PSX(553.1,",DR="2////"_PSXFM D ^DIE K DA,DR,DIE,PSXTS,PSXFM L -^PSX(553.1,QRYN) D Q
22 ..S DA=XX0,DIE="^PSX(552.3,",DR="1////1" D ^DIE K DA,DIE,DR
23 .I $E(TNODE,1,4)["ZMP|" D ZMP S ZMPFLG=1 Q
24 .I $E(TNODE,1,4)["MSH|" S DA=XX0,DR="1////1",DIE="^PSX(552.3," D ^DIE K DA,DR,DIE D Q
25 .I $E(TNODE,1,8)["NTE|99||" D
26 ..;S DA=XX0,DIE="^PSX(552.3,",DR="1////1" D ^DIE K DA,DR,DIE
27 ..S STAT=$P(TNODE,"\",3),RXN=$P($P(TNODE,"\",1),"|",4),FACBAT=$P($P(TNODE,"\F\",6),"-",1,2)
28 ..S PSXTS=$P(TNODE,"\",5) D TSIN^PSXUTL S COMDT=PSXFM
29 ..S EMPID=$P(TNODE,"\",9),RXSTAT=1
30 ..S PSXNDC=$P(TNODE,"\",7)
31 ..S NPTR=$P($P(TNODE,"\",11),"-",1,2)
32 ..K XX2 S:$G(^PSX(552.3,XX1,0))["NTE|100" XX2=XX1 ;flag for NTE|100 present
33 ..I STAT="CA" D
34 ...I '$G(XX2) S ^XTMP("PSXBAD "_DT,XX1)=$G(TNODE) Q
35 ...S STAT=2,CANFLG=1,REASON=$P($P(^PSX(552.3,XX1,0),"\F",1),"|",4)
36 ..I STAT="CO" S STAT=1 D
37 ...I '$G(XX2) S ^XTMP("PSXBAD "_DT,XX1)=$G(TNODE) Q
38 ...S SHPDT=$P(^PSX(552.3,XX1,0),"\F\",2),CARRIER=$P(^PSX(552.3,XX1,0),"\F\",3),PKID=$P(^PSX(552.3,XX1,0),"\F\",4) S:$G(CARRIER)="" CARRIER="UNK"
39 ...I $G(SHPDT) S SHPDT=$$HL7TFM^XLFDT(SHPDT)
40 ..K PSXLOT S CC=0 F BB=13:4 Q:$P(TNODE,"\",BB)="" S CC=CC+1,PSXLOT(CC)=$P(TNODE,"\",BB)_"^"_$P(TNODE,"\",BB+2)
41 ..D FILE S DA=XX0,DIE="^PSX(552.3,",DR="1////1" D ^DIE K DA I $G(XX2) S DA=XX2 D ^DIE K DA,DR,XX2,DIE
42 ..K COMDT,STAT,REASON,PSXNDC,EMPID,COST,RXSTAT,BB,RXN,TDT,XDA,NPTR
43 ..K PSXLOT,STAT1,STAT2,ZMPFLG,SHPDT,CARRIER,PKID,XX2
44 I '$O(^XTMP("PSXBAD "_DT,0)) K ^XTMP("PSXBAD "_DT,0)
45FIN D EN^PSXVEND
46 D:CANFLG>0 CAN^PSXMSGS
47 S $P(^PSX(554,1,1,R554,0),U,4)="S"
48 D NDRGMSG^PSXRTN,NEXT^PSXRTN
49 I $G(^TMP($J,"PSXDUP"))'="" S XQAMSG="Duplicate release data received from the vendor system.",XQAROU="ALRT^PSXDRPT",XQAID="PSX" D GRP1^PSXNOTE,SETUP^XQALERT K ^TMP($J,"PSXDUP")
50 K LST,LSTQRY,QRYNQ,STOP,TNODE,XX0,XX1,R554,CANFLG,PSXTS,QRYN,QRYD
51 Q
52FILE ;store the data in the RX multiple, PSX(515
53 K DD,DO,NREC,UU,VV,CC,X,AA,SS,CNT,LOT,EXPDT
54 Q:'$D(^PSX(552.1,"B",NPTR))
55 S UU=$O(^PSX(552.1,"B",NPTR,"")) Q:'UU S:$G(STAT)=2 SITE=$P($P(^PSX(552.1,UU,0),"^",1),"-",1),TDT=$P(^PSX(552.1,UU,0),"^",3),PSXDIV=$P(^PSX(552.1,UU,"P"),"^")
56 S CC=$O(^PSX(552.4,"B",UU,"")) Q:'CC S NREC=CC
57 I '$D(^PSX(552.4,NREC,1,"B",RXN)) Q ;generate an error message that the rx doesn't exist
58 S XDA=$O(^PSX(552.4,NREC,1,"B",RXN,""))
59 I $P(^PSX(552.4,NREC,1,XDA,0),"^",9)'="" S ^TMP($J,"PSXDUP",RXN)=$G(^PSX(552.3,XX0,0)),DA=XX0,DIE="^PSX(552.3,",DR="1////3" D ^DIE K DA D Q
60 .I $G(QRYD)>0 S DA=QRYD D ^DIE K DA,DR,DIE Q
61 S:$G(REASON)]"" REASON=$TR(REASON,"^"," ")
62 I $G(STAT)=2 S FILL=$P(^PSX(552.4,NREC,1,XDA,0),"^",12),^TMP($J,"PSXCAN",PSXDIV,SITE,RXN)=FACBAT_"^"_FILL_"^"_TDT_"^"_$G(REASON)
63 I $G(STAT)=1 S IDDRG=$P(^PSX(552.4,NREC,1,XDA,0),"^",4),IEN50=$O(^PSDRUG("AQ1",$G(IDDRG),"")) S:$G(IEN50)'="" COST=$P(^PSDRUG($G(IEN50),660),U,6) S:$G(IEN50)=""!($G(COST)="") ^TMP($J,"PSXNDG",$G(IDDRG),$G(COMDT))=RXN_"^"_NPTR
64LOCK L +^PSX(552.4,NREC):30 G:'$T LOCK
65 S DA=XDA,DA(1)=NREC,DIE="^PSX(552.4,"_NREC_",1,"
66 S STAT1=".02////"_$G(COMDT)_";1////"_$G(STAT)_";4////"_$G(PSXNDC)_";5////"_$G(EMPID)_";8////"_$G(QRYN)_";9////1;10////"_$G(COST)_";13////"_$G(RXSTAT)_";16////"_$G(SHPDT)_";17////"_$G(CARRIER)_";18////"_$G(PKID)
67 S STAT2=".02////"_$G(COMDT)_";1////"_$G(STAT)_";2////^S X=$G(REASON);5////"_$G(EMPID)_";8////"_$G(QRYN)_";9////1;13////"_$G(RXSTAT)
68 S DR=$S($G(STAT)=1:STAT1,$G(STAT)=2:STAT2,1:"")
69 D ^DIE K DIE,DR,DA
70 L -^PSX(552.4,NREC)
71 K LOT,EXPDT,CNT
72 S SS=0 F S SS=$O(PSXLOT(SS)) Q:SS'>0 S CNT=SS D
73 .Q:$G(STAT)=2!($G(ZMPFLG)=1)
74 .S:'$D(^PSX(552.4,NREC,1,XDA,1,0)) ^PSX(552.4,NREC,1,XDA,1,0)="^552.56A^^"
75 .S LOT=$P(PSXLOT(CNT),U,1),PSXTS=$P(PSXLOT(CNT),U,2) D TSIN^PSXUTL S EXPDT=$P(PSXFM,".",1) K PSXTS,PSXFM
76 .S DA(2)=NREC,DA(1)=XDA,X=LOT,DIC(0)="Z",DIC="^PSX(552.4,"_NREC_",1,"_XDA_",1,",DIC("DR")="1////"_EXPDT D FILE^DICN K DIC,LOT,EXPDT,DA,DIC("DR"),DIC(0)
77 K SITE,REASON,UU,FACBAT,FILL,I,XYDA,IDDRG,IEN50
78 Q
79ZMP Q:$P($G(TNODE),"|",7)=""
80 S (FACBAT,NPTR)=$P($P(TNODE,"|",2),"-",1,2),RXN=$P(TNODE,"|",3),STAT=$S($P(^PSX(552.3,XX0,0),"|",9)'="":2,1:"1"),REASON=$P(TNODE,"|",9),EMPID=$P(TNODE,"|",8),COMDT=$P(TNODE,"|",7),RXSTAT=2,DA=XX0,DR="1////1",DIE="^PSX(552.3,"
81 D ^DIE K DA,DR,DIE
82 D FILE
83 Q
Note: See TracBrowser for help on using the repository browser.