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

PSXDODQY ;BIR/HTW-Send Release Data to DoD ;04/08/97 2:06 Pm
 ;;2.0;CMOP;**38,45**;11 Apr 97
 ;Reference to $$CMOP^PSNAPIS supported by DBIA #2574
DOD ; GET THE DATA FOR 1 TRANSMISSION...ZX=SITE #
 D NOW^%DTC S CREATEDT=$$FMTHL7^XLFDT(%),CREATEDT=$P(CREATEDT,"-") D BATCH S QRYBAT=$E(ZX,2,99)_"-"_BATCH,FILENAME=$TR(QRYBAT,"-","_")_".QRY"
 ;Segment order for fulfillment file. FHS,BHS,MSH,PID,NTE8,ORC,RXD,ZR2,BTS,FTS
 S CNT=1
 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
 .S NODEA=$G(^PSX(552.4,AA,0))
 .S NODE0=$G(^PSX(552.4,AA,1,BB,0))
 .S NODE2=$G(^PSX(552.4,AA,1,BB,2))
 .S ORDER=$P($G(^PSX(552.4,AA,1,BB,3)),"^")
 .S FACBAT=$P(^PSX(552.1,+$P($G(NODEA),"^"),0),"^")
 .;Maintain full transmission # with leading 1 for file negotiations
 .S TRN=$S($G(ORDER):FACBAT_"-"_$G(ORDER),1:"") ; TRN= TRANSMISSION # - SITEID-BATCH#-ORDER#
 .S FAC1=$P(FACBAT,"-"),FACBAT=$E(FACBAT,2,99),FAC=$P(FACBAT,"-") ; FAC1=1+SITE,FAC=SITE
 .I CNT=1 S X=$$FMADD^XLFDT(DT,+2) S ^XTMP("PSXQRY"_QRYBAT,0)=X_U_DT_U_"CMOP DOD QUERY" K X
 .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)
 .;COMBINE CMOPID/VA PRINT NAME
 .S VAPRT=$$CMOP^PSNAPIS(DRG),DRG=DRG_"^"_VAPRT_"^"_"L" K VAPRT
 .F YY="SHPDT^4","CARRIER^5","PKGID^6" D PIECE(NODE2,DLM,YY)
 .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
 ..S EX1=$P($G(LOTX),"^",2),$P(EXPDT,"~",CC)=$$FMTHL7^XLFDT(EX1) K EX1
 .;Find the order containing the Rx in 552.2
 .S R=$O(^PSX(552.2,"B",TRN,"")) ; R=IEN 552.2
 .I $G(R)']"" H 1 D  Q
 .. S ERRTXT(1)="Can't link order # from 552.4 to 552.2 ",ERRTXT(2)="Transmission #: "_FACBAT_" Order "_BB,ERRTXT(3)="Routine PSXDODQY"
 .. D MSG^PSXDODAC
 .. K ^PSX(552.4,"AC",ZX,AA,BB)
 .; Get info from 552.2
 .S RXCNT=$G(RXCNT)+1
 .F R1=0:0 S R1=$O(^PSX(552.2,R,"T",R1)) Q:'R1  S ND1=$G(^(R1,0)) D
 ..I $P($G(ND1),"|")["PID" S PID=ND1,PNAME=$P(PID,"|",6),PNAME="^"_$TR(PNAME," ","^"),$P(PID,"|",6)=PNAME
 ..I $P($G(ND1),"|")["NTE|8" S NTE8=ND1
 ..;Unmodify RXINDEX to remove leading 1
 ..I $P($G(ND1),"|")["RX1"&($G(ND1)[RXN) S Z1=$P(ND1,"|",2),RXINDEX=$E(Z1,2,99) K Z1
 ..I $G(ND1)["ZX1"&($G(ND1)[RXN) S PSXDODNM=$P($P(ND1,"|",3),"^",2)
 ..K ND1
 .S DLM="|"
 .I $G(CNT)=1 D
 ..S PSXHOME=$P($G(^PSX(554,1,0)),"^")
 ..S NODE="FHS|^~\&|VISTA|"_$G(PSXHOME)_"||"_$G(PSXDODNM)_"|"_$G(CREATEDT)_"||||"_FILENAME D PSXTMP
 ..S NODE="BHS|^~\&|VISTA|"_$G(PSXHOME)_"|"_$G(PSXDODNM)_"|"_$G(CREATEDT)_"||||"_QRYBAT D PSXTMP
 .S NODE="MSH|^~\&|VistA||CHCS||"_CREATEDT_"||RDS^R06|"_RXINDEX_"|P|2.3.1||||AL|AL" D PSXTMP
 .S NODE=PID D PSXTMP
 .S NODE="ORC|"_$S($G(STAT)=2:"CA",1:"OK")_"|"_RXINDEX D PSXTMP
 .S RXD="RXD|"
 .F YY="FILNUM^2","DRG^3","COMPDT^4","QTY^5","RXN^8","REASON^10","LOT^19","EXPDT^20" D PUT(.RXD,DLM,YY)
 .S NODE=RXD D PSXTMP
 .S ZR2="ZR2|" F YY="CARRIER^2","PKGID^3","RXN^4" D PUT(.ZR2,DLM,YY)
 .S NODE=ZR2 D PSXTMP
 .L +^PSX(552.4,AA,1,BB):600 Q:'$T
 .S DA=BB,DA(1)=AA,DIE="^PSX(552.4,"_AA_",1,",DR="9////2;15////"_BATCH D ^DIE K DA,DR,DIE
 .L -^PSX(552.4,AA,1,BB)
KIL .K NDC,COMPDT,STAT,REASON,LOT,RXN,CARRIER,PKGID,SHPDT,NODEA,NODE1,NODE2,LOT,EXPDT,LOTX
 I $G(RXCNT)<1 Q
 S NODE="BTS|"_RXCNT_"||"_RXCNT D PSXTMP
 S NODE="FTS|"_1 D PSXTMP
 S A="PSXQRY",PATH=$P($G(^PSX(554,1,"DOD")),"^",2)
 F XX=1:1:5 S Y=$$GTF^%ZISH($NA(^XTMP(A_QRYBAT,1)),3,PATH,FILENAME) Q:Y=1  H 4
 I Y'=1 S GBL=$NA(^XTMP(A_QRYBAT)) D FALERT^PSXDODNT(FILENAME,PATH,GBL)
 I Y=0 S ERRTXT(2)="Failure writing to file: "_FILENAME,ERRTXT(3)="Error occurred at KIL+4^PSXDODQY" D MSG^PSXDODAC Q
 S PATH=$$GET1^DIQ(554,1,22)
 F XX=1:1:5 S Y=$$GTF^%ZISH($NA(^XTMP(A_QRYBAT,1)),3,PATH,FILENAME) Q:Y=1  H 4
 I Y'=1 S GBL=$NA(^XTMP(A_QRYBAT)) D FALERT^PSXDODNT(FILENAME,PATH,GBL)
 K DD,DO
 D NOW^%DTC
 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
 K BATCH,FAC,RXCNT
 Q
PSXTMP ;
 S ^XTMP("PSXQRY"_QRYBAT,CNT)=NODE S CNT=$G(CNT)+1 K NODE
 Q
BATCH ;CREATE BATCH # YY_JULIAN DATE_HH_MM
 N J1,J2,JDT,X1,X2
 S X1=$E(%,1,3)_"0101",X2=DT+1,JDT=$$FMDIFF^XLFDT(X1,X2,1)
 ;change sign - to +
 S JDT=(JDT*-1)
 ;pad with 0s
 I $L(JDT)<3 F I=1:1:(3-$L(JDT)) S JDT="0"_JDT
 S J1=$E(%,2,3),J2=$E(%,9,12),BATCH=J1_JDT_J2
 I $L(BATCH)<9 F I=1:1:(9-$L(BATCH)) S BATCH=BATCH_"0"
 Q
PUT(REC,DLM,XX) ;
 N Y,I S Y=$P(XX,U),I=$P(XX,U,2)
 S $P(REC,DLM,I)=$G(@Y)
 Q
PIECE(REC,DLM,XX) ;
 N Y,I S Y=$P(XX,U),I=$P(XX,U,2),@Y=$P(REC,DLM,I)
 Q