- 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 Jan 18, 2025@02:45:20 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