source: FOIAVistA/tag/r/CMOP-PSX/PSXDODQY.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 4.4 KB
Line 
1PSXDODQY ;BIR/HTW-Send Release Data to DoD ;04/08/97 2:06 Pm
2 ;;2.0;CMOP;**38,45**;11 Apr 97
3 ;Reference to $$CMOP^PSNAPIS supported by DBIA #2574
4DOD ; GET THE DATA FOR 1 TRANSMISSION...ZX=SITE #
5 D NOW^%DTC S CREATEDT=$$FMTHL7^XLFDT(%),CREATEDT=$P(CREATEDT,"-") D BATCH S QRYBAT=$E(ZX,2,99)_"-"_BATCH,FILENAME=$TR(QRYBAT,"-","_")_".QRY"
6 ;Segment order for fulfillment file. FHS,BHS,MSH,PID,NTE8,ORC,RXD,ZR2,BTS,FTS
7 S CNT=1
8 F AA=0:0 S AA=$O(^PSX(552.4,"AC",ZX,AA)) Q:AA'>0 S BB=0 F S BB=$O(^PSX(552.4,"AC",ZX,AA,BB)) Q:BB'>0 D
9 .S NODEA=$G(^PSX(552.4,AA,0))
10 .S NODE0=$G(^PSX(552.4,AA,1,BB,0))
11 .S NODE2=$G(^PSX(552.4,AA,1,BB,2))
12 .S ORDER=$P($G(^PSX(552.4,AA,1,BB,3)),"^")
13 .S FACBAT=$P(^PSX(552.1,+$P($G(NODEA),"^"),0),"^")
14 .;Maintain full transmission # with leading 1 for file negotiations
15 .S TRN=$S($G(ORDER):FACBAT_"-"_$G(ORDER),1:"") ; TRN= TRANSMISSION # - SITEID-BATCH#-ORDER#
16 .S FAC1=$P(FACBAT,"-"),FACBAT=$E(FACBAT,2,99),FAC=$P(FACBAT,"-") ; FAC1=1+SITE,FAC=SITE
17 .I CNT=1 S X=$$FMADD^XLFDT(DT,+2) S ^XTMP("PSXQRY"_QRYBAT,0)=X_U_DT_U_"CMOP DOD QUERY" K X
18 .F YY="RXN^1","STAT^2","REASON^3","DRG^4","NDC^5","COMPDT^9","FILNUM^12","QTY^13" S DLM="^" D PIECE(NODE0,DLM,YY)
19 .;COMBINE CMOPID/VA PRINT NAME
20 .S VAPRT=$$CMOP^PSNAPIS(DRG),DRG=DRG_"^"_VAPRT_"^"_"L" K VAPRT
21 .F YY="SHPDT^4","CARRIER^5","PKGID^6" D PIECE(NODE2,DLM,YY)
22 .F CC=0:0 S CC=$O(^PSX(552.4,AA,1,BB,1,CC)) Q:CC'>0 S LOTX=$G(^PSX(552.4,AA,1,BB,1,CC,0)),$P(LOT,"~",CC)=$P($G(LOTX),"^") D
23 ..S EX1=$P($G(LOTX),"^",2),$P(EXPDT,"~",CC)=$$FMTHL7^XLFDT(EX1) K EX1
24 .;Find the order containing the Rx in 552.2
25 .S R=$O(^PSX(552.2,"B",TRN,"")) ; R=IEN 552.2
26 .I $G(R)']"" H 1 D Q
27 .. S ERRTXT(1)="Can't link order # from 552.4 to 552.2 ",ERRTXT(2)="Transmission #: "_FACBAT_" Order "_BB,ERRTXT(3)="Routine PSXDODQY"
28 .. D MSG^PSXDODAC
29 .. K ^PSX(552.4,"AC",ZX,AA,BB)
30 .; Get info from 552.2
31 .S RXCNT=$G(RXCNT)+1
32 .F R1=0:0 S R1=$O(^PSX(552.2,R,"T",R1)) Q:'R1 S ND1=$G(^(R1,0)) D
33 ..I $P($G(ND1),"|")["PID" S PID=ND1,PNAME=$P(PID,"|",6),PNAME="^"_$TR(PNAME," ","^"),$P(PID,"|",6)=PNAME
34 ..I $P($G(ND1),"|")["NTE|8" S NTE8=ND1
35 ..;Unmodify RXINDEX to remove leading 1
36 ..I $P($G(ND1),"|")["RX1"&($G(ND1)[RXN) S Z1=$P(ND1,"|",2),RXINDEX=$E(Z1,2,99) K Z1
37 ..I $G(ND1)["ZX1"&($G(ND1)[RXN) S PSXDODNM=$P($P(ND1,"|",3),"^",2)
38 ..K ND1
39 .S DLM="|"
40 .I $G(CNT)=1 D
41 ..S PSXHOME=$P($G(^PSX(554,1,0)),"^")
42 ..S NODE="FHS|^~\&|VISTA|"_$G(PSXHOME)_"||"_$G(PSXDODNM)_"|"_$G(CREATEDT)_"||||"_FILENAME D PSXTMP
43 ..S NODE="BHS|^~\&|VISTA|"_$G(PSXHOME)_"|"_$G(PSXDODNM)_"|"_$G(CREATEDT)_"||||"_QRYBAT D PSXTMP
44 .S NODE="MSH|^~\&|VistA||CHCS||"_CREATEDT_"||RDS^R06|"_RXINDEX_"|P|2.3.1||||AL|AL" D PSXTMP
45 .S NODE=PID D PSXTMP
46 .S NODE="ORC|"_$S($G(STAT)=2:"CA",1:"OK")_"|"_RXINDEX D PSXTMP
47 .S RXD="RXD|"
48 .F YY="FILNUM^2","DRG^3","COMPDT^4","QTY^5","RXN^8","REASON^10","LOT^19","EXPDT^20" D PUT(.RXD,DLM,YY)
49 .S NODE=RXD D PSXTMP
50 .S ZR2="ZR2|" F YY="CARRIER^2","PKGID^3","RXN^4" D PUT(.ZR2,DLM,YY)
51 .S NODE=ZR2 D PSXTMP
52 .L +^PSX(552.4,AA,1,BB):600 Q:'$T
53 .S DA=BB,DA(1)=AA,DIE="^PSX(552.4,"_AA_",1,",DR="9////2;15////"_BATCH D ^DIE K DA,DR,DIE
54 .L -^PSX(552.4,AA,1,BB)
55KIL .K NDC,COMPDT,STAT,REASON,LOT,RXN,CARRIER,PKGID,SHPDT,NODEA,NODE1,NODE2,LOT,EXPDT,LOTX
56 I $G(RXCNT)<1 Q
57 S NODE="BTS|"_RXCNT_"||"_RXCNT D PSXTMP
58 S NODE="FTS|"_1 D PSXTMP
59 S A="PSXQRY",PATH=$P($G(^PSX(554,1,"DOD")),"^",2)
60 F XX=1:1:5 S Y=$$GTF^%ZISH($NA(^XTMP(A_QRYBAT,1)),3,PATH,FILENAME) Q:Y=1 H 4
61 I Y'=1 S GBL=$NA(^XTMP(A_QRYBAT)) D FALERT^PSXDODNT(FILENAME,PATH,GBL)
62 I Y=0 S ERRTXT(2)="Failure writing to file: "_FILENAME,ERRTXT(3)="Error occurred at KIL+4^PSXDODQY" D MSG^PSXDODAC Q
63 S PATH=$$GET1^DIQ(554,1,22)
64 F XX=1:1:5 S Y=$$GTF^%ZISH($NA(^XTMP(A_QRYBAT,1)),3,PATH,FILENAME) Q:Y=1 H 4
65 I Y'=1 S GBL=$NA(^XTMP(A_QRYBAT)) D FALERT^PSXDODNT(FILENAME,PATH,GBL)
66 K DD,DO
67 D NOW^%DTC
68 S DA(1)=1,DIC="^PSX(554,"_DA(1)_",3,",DIC(0)="Z",DIC("DR")="1////"_BATCH_";2////"_FAC1_";5////"_RXCNT,X=% D FILE^DICN K DIC,DA,DIC("DR"),DIC(0),X,TRX
69 K BATCH,FAC,RXCNT
70 Q
71PSXTMP ;
72 S ^XTMP("PSXQRY"_QRYBAT,CNT)=NODE S CNT=$G(CNT)+1 K NODE
73 Q
74BATCH ;CREATE BATCH # YY_JULIAN DATE_HH_MM
75 N J1,J2,JDT,X1,X2
76 S X1=$E(%,1,3)_"0101",X2=DT+1,JDT=$$FMDIFF^XLFDT(X1,X2,1)
77 ;change sign - to +
78 S JDT=(JDT*-1)
79 ;pad with 0s
80 I $L(JDT)<3 F I=1:1:(3-$L(JDT)) S JDT="0"_JDT
81 S J1=$E(%,2,3),J2=$E(%,9,12),BATCH=J1_JDT_J2
82 I $L(BATCH)<9 F I=1:1:(9-$L(BATCH)) S BATCH=BATCH_"0"
83 Q
84PUT(REC,DLM,XX) ;
85 N Y,I S Y=$P(XX,U),I=$P(XX,U,2)
86 S $P(REC,DLM,I)=$G(@Y)
87 Q
88PIECE(REC,DLM,XX) ;
89 N Y,I S Y=$P(XX,U),I=$P(XX,U,2),@Y=$P(REC,DLM,I)
90 Q
Note: See TracBrowser for help on using the repository browser.