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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXDODQY 4638 printed Apr 09, 2024@20:50:46 Page 2
PSXDODQY ;BIR/HTW-Send Release Data to DoD ;04/08/97 2:06 Pm
+1 ;;2.0;CMOP;**38,45**;11 Apr 97
+2 ;Reference to $$CMOP^PSNAPIS supported by DBIA #2574
DOD ; GET THE DATA FOR 1 TRANSMISSION...ZX=SITE #
+1 DO NOW^%DTC
SET CREATEDT=$$FMTHL7^XLFDT(%)
SET CREATEDT=$PIECE(CREATEDT,"-")
DO BATCH
SET QRYBAT=$EXTRACT(ZX,2,99)_"-"_BATCH
SET FILENAME=$TRANSLATE(QRYBAT,"-","_")_".QRY"
+2 ;Segment order for fulfillment file. FHS,BHS,MSH,PID,NTE8,ORC,RXD,ZR2,BTS,FTS
+3 SET CNT=1
+4 FOR AA=0:0
SET AA=$ORDER(^PSX(552.4,"AC",ZX,AA))
if AA'>0
QUIT
SET BB=0
FOR
SET BB=$ORDER(^PSX(552.4,"AC",ZX,AA,BB))
if BB'>0
QUIT
Begin DoDot:1
+5 SET NODEA=$GET(^PSX(552.4,AA,0))
+6 SET NODE0=$GET(^PSX(552.4,AA,1,BB,0))
+7 SET NODE2=$GET(^PSX(552.4,AA,1,BB,2))
+8 SET ORDER=$PIECE($GET(^PSX(552.4,AA,1,BB,3)),"^")
+9 SET FACBAT=$PIECE(^PSX(552.1,+$PIECE($GET(NODEA),"^"),0),"^")
+10 ;Maintain full transmission # with leading 1 for file negotiations
+11 ; TRN= TRANSMISSION # - SITEID-BATCH#-ORDER#
SET TRN=$SELECT($GET(ORDER):FACBAT_"-"_$GET(ORDER),1:"")
+12 ; FAC1=1+SITE,FAC=SITE
SET FAC1=$PIECE(FACBAT,"-")
SET FACBAT=$EXTRACT(FACBAT,2,99)
SET FAC=$PIECE(FACBAT,"-")
+13 IF CNT=1
SET X=$$FMADD^XLFDT(DT,+2)
SET ^XTMP("PSXQRY"_QRYBAT,0)=X_U_DT_U_"CMOP DOD QUERY"
KILL X
+14 FOR YY="RXN^1","STAT^2","REASON^3","DRG^4","NDC^5","COMPDT^9","FILNUM^12","QTY^13"
SET DLM="^"
DO PIECE(NODE0,DLM,YY)
+15 ;COMBINE CMOPID/VA PRINT NAME
+16 SET VAPRT=$$CMOP^PSNAPIS(DRG)
SET DRG=DRG_"^"_VAPRT_"^"_"L"
KILL VAPRT
+17 FOR YY="SHPDT^4","CARRIER^5","PKGID^6"
DO PIECE(NODE2,DLM,YY)
+18 FOR CC=0:0
SET CC=$ORDER(^PSX(552.4,AA,1,BB,1,CC))
if CC'>0
QUIT
SET LOTX=$GET(^PSX(552.4,AA,1,BB,1,CC,0))
SET $PIECE(LOT,"~",CC)=$PIECE($GET(LOTX),"^")
Begin DoDot:2
+19 SET EX1=$PIECE($GET(LOTX),"^",2)
SET $PIECE(EXPDT,"~",CC)=$$FMTHL7^XLFDT(EX1)
KILL EX1
End DoDot:2
+20 ;Find the order containing the Rx in 552.2
+21 ; R=IEN 552.2
SET R=$ORDER(^PSX(552.2,"B",TRN,""))
+22 IF $GET(R)']""
HANG 1
Begin DoDot:2
+23 SET ERRTXT(1)="Can't link order # from 552.4 to 552.2 "
SET ERRTXT(2)="Transmission #: "_FACBAT_" Order "_BB
SET ERRTXT(3)="Routine PSXDODQY"
+24 DO MSG^PSXDODAC
+25 KILL ^PSX(552.4,"AC",ZX,AA,BB)
End DoDot:2
QUIT
+26 ; Get info from 552.2
+27 SET RXCNT=$GET(RXCNT)+1
+28 FOR R1=0:0
SET R1=$ORDER(^PSX(552.2,R,"T",R1))
if 'R1
QUIT
SET ND1=$GET(^(R1,0))
Begin DoDot:2
+29 IF $PIECE($GET(ND1),"|")["PID"
SET PID=ND1
SET PNAME=$PIECE(PID,"|",6)
SET PNAME="^"_$TRANSLATE(PNAME," ","^")
SET $PIECE(PID,"|",6)=PNAME
+30 IF $PIECE($GET(ND1),"|")["NTE|8"
SET NTE8=ND1
+31 ;Unmodify RXINDEX to remove leading 1
+32 IF $PIECE($GET(ND1),"|")["RX1"&($GET(ND1)[RXN)
SET Z1=$PIECE(ND1,"|",2)
SET RXINDEX=$EXTRACT(Z1,2,99)
KILL Z1
+33 IF $GET(ND1)["ZX1"&($GET(ND1)[RXN)
SET PSXDODNM=$PIECE($PIECE(ND1,"|",3),"^",2)
+34 KILL ND1
End DoDot:2
+35 SET DLM="|"
+36 IF $GET(CNT)=1
Begin DoDot:2
+37 SET PSXHOME=$PIECE($GET(^PSX(554,1,0)),"^")
+38 SET NODE="FHS|^~\&|VISTA|"_$GET(PSXHOME)_"||"_$GET(PSXDODNM)_"|"_$GET(CREATEDT)_"||||"_FILENAME
DO PSXTMP
+39 SET NODE="BHS|^~\&|VISTA|"_$GET(PSXHOME)_"|"_$GET(PSXDODNM)_"|"_$GET(CREATEDT)_"||||"_QRYBAT
DO PSXTMP
End DoDot:2
+40 SET NODE="MSH|^~\&|VistA||CHCS||"_CREATEDT_"||RDS^R06|"_RXINDEX_"|P|2.3.1||||AL|AL"
DO PSXTMP
+41 SET NODE=PID
DO PSXTMP
+42 SET NODE="ORC|"_$SELECT($GET(STAT)=2:"CA",1:"OK")_"|"_RXINDEX
DO PSXTMP
+43 SET RXD="RXD|"
+44 FOR YY="FILNUM^2","DRG^3","COMPDT^4","QTY^5","RXN^8","REASON^10","LOT^19","EXPDT^20"
DO PUT(.RXD,DLM,YY)
+45 SET NODE=RXD
DO PSXTMP
+46 SET ZR2="ZR2|"
FOR YY="CARRIER^2","PKGID^3","RXN^4"
DO PUT(.ZR2,DLM,YY)
+47 SET NODE=ZR2
DO PSXTMP
+48 LOCK +^PSX(552.4,AA,1,BB):600
if '$TEST
QUIT
+49 SET DA=BB
SET DA(1)=AA
SET DIE="^PSX(552.4,"_AA_",1,"
SET DR="9////2;15////"_BATCH
DO ^DIE
KILL DA,DR,DIE
+50 LOCK -^PSX(552.4,AA,1,BB)
KIL KILL NDC,COMPDT,STAT,REASON,LOT,RXN,CARRIER,PKGID,SHPDT,NODEA,NODE1,NODE2,LOT,EXPDT,LOTX
End DoDot:1
+1 IF $GET(RXCNT)<1
QUIT
+2 SET NODE="BTS|"_RXCNT_"||"_RXCNT
DO PSXTMP
+3 SET NODE="FTS|"_1
DO PSXTMP
+4 SET A="PSXQRY"
SET PATH=$PIECE($GET(^PSX(554,1,"DOD")),"^",2)
+5 FOR XX=1:1:5
SET Y=$$GTF^%ZISH($NAME(^XTMP(A_QRYBAT,1)),3,PATH,FILENAME)
if Y=1
QUIT
HANG 4
+6 IF Y'=1
SET GBL=$NAME(^XTMP(A_QRYBAT))
DO FALERT^PSXDODNT(FILENAME,PATH,GBL)
+7 IF Y=0
SET ERRTXT(2)="Failure writing to file: "_FILENAME
SET ERRTXT(3)="Error occurred at KIL+4^PSXDODQY"
DO MSG^PSXDODAC
QUIT
+8 SET PATH=$$GET1^DIQ(554,1,22)
+9 FOR XX=1:1:5
SET Y=$$GTF^%ZISH($NAME(^XTMP(A_QRYBAT,1)),3,PATH,FILENAME)
if Y=1
QUIT
HANG 4
+10 IF Y'=1
SET GBL=$NAME(^XTMP(A_QRYBAT))
DO FALERT^PSXDODNT(FILENAME,PATH,GBL)
+11 KILL DD,DO
+12 DO NOW^%DTC
+13 SET DA(1)=1
SET DIC="^PSX(554,"_DA(1)_",3,"
SET DIC(0)="Z"
SET DIC("DR")="1////"_BATCH_";2////"_FAC1_";5////"_RXCNT
SET X=%
DO FILE^DICN
KILL DIC,DA,DIC("DR"),DIC(0),X,TRX
+14 KILL BATCH,FAC,RXCNT
+15 QUIT
PSXTMP ;
+1 SET ^XTMP("PSXQRY"_QRYBAT,CNT)=NODE
SET CNT=$GET(CNT)+1
KILL NODE
+2 QUIT
BATCH ;CREATE BATCH # YY_JULIAN DATE_HH_MM
+1 NEW J1,J2,JDT,X1,X2
+2 SET X1=$EXTRACT(%,1,3)_"0101"
SET X2=DT+1
SET JDT=$$FMDIFF^XLFDT(X1,X2,1)
+3 ;change sign - to +
+4 SET JDT=(JDT*-1)
+5 ;pad with 0s
+6 IF $LENGTH(JDT)<3
FOR I=1:1:(3-$LENGTH(JDT))
SET JDT="0"_JDT
+7 SET J1=$EXTRACT(%,2,3)
SET J2=$EXTRACT(%,9,12)
SET BATCH=J1_JDT_J2
+8 IF $LENGTH(BATCH)<9
FOR I=1:1:(9-$LENGTH(BATCH))
SET BATCH=BATCH_"0"
+9 QUIT
PUT(REC,DLM,XX) ;
+1 NEW Y,I
SET Y=$PIECE(XX,U)
SET I=$PIECE(XX,U,2)
+2 SET $PIECE(REC,DLM,I)=$GET(@Y)
+3 QUIT
PIECE(REC,DLM,XX) ;
+1 NEW Y,I
SET Y=$PIECE(XX,U)
SET I=$PIECE(XX,U,2)
SET @Y=$PIECE(REC,DLM,I)
+2 QUIT
