PSXRTN1 ;BIR/WPB,HTW-Background filer for V2 ;MAR 1,2002@16:11:17
;;2.0;CMOP;**1,2,14,23,32**;11 Apr 97
;Reference to ^PSDRUG( supported by DBIA #1983
DATA ;gets the data from PSX(513
S PSXZTSK=ZTSK
S R554=$O(^PSX(554,"AB",""))
I $P($G(^PSX(554,1,1,R554,0)),U,4)="R" D NEXT^PSXRTN Q
S $P(^PSX(554,1,1,R554,0),U,4)="R"
EN K ^TMP($J,"PSXCAN"),XX0,ZZ,REC,TNODE
S X=$$FMADD^XLFDT(DT,+7),^XTMP("PSXBAD "_DT,0)=X_U_DT_U_"Vendor Missing NTE|100 segments"
S (CANFLG,STOP,ZMPFLG)=0
S LSTQRY=$O(^PSX(553.2,"A"),-1)
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
.I $E(TNODE,1,7)["NTE|100" S DA=XX0,DR="1////1",DIE="^PSX(552.3," D ^DIE K DIE,DA,DR Q
.I $E(TNODE,1,4)["PID|" S DA=XX0,DIE="^PSX(552.3,",DR="1////1" D ^DIE K DA,DR,DIE Q
.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
..I $G(QRYN)>0 S:($G(QRYN)=LSTQRY)&($P(^PSX(553.1,QRYN,0),"^",5)'=1) STOP=1
.Q:$G(STOP)>0
.S:$G(QRYN)'>0 QRYN=LSTQRY-1
.I $E(TNODE,1,3)["BTS" S DA=XX0,DR="1////1",DIE="^PSX(552.3," D ^DIE K DA,DR,DIE,QRYD Q
.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
..S DA=XX0,DIE="^PSX(552.3,",DR="1////1" D ^DIE K DA,DIE,DR
.I $E(TNODE,1,4)["ZMP|" D ZMP S ZMPFLG=1 Q
.I $E(TNODE,1,4)["MSH|" S DA=XX0,DR="1////1",DIE="^PSX(552.3," D ^DIE K DA,DR,DIE D Q
.I $E(TNODE,1,8)["NTE|99||" D
..;S DA=XX0,DIE="^PSX(552.3,",DR="1////1" D ^DIE K DA,DR,DIE
..S STAT=$P(TNODE,"\",3),RXN=$P($P(TNODE,"\",1),"|",4),FACBAT=$P($P(TNODE,"\F\",6),"-",1,2)
..S PSXTS=$P(TNODE,"\",5) D TSIN^PSXUTL S COMDT=PSXFM
..S EMPID=$P(TNODE,"\",9),RXSTAT=1
..S PSXNDC=$P(TNODE,"\",7)
..S NPTR=$P($P(TNODE,"\",11),"-",1,2)
..K XX2 S:$G(^PSX(552.3,XX1,0))["NTE|100" XX2=XX1 ;flag for NTE|100 present
..I STAT="CA" D
...I '$G(XX2) S ^XTMP("PSXBAD "_DT,XX1)=$G(TNODE) Q
...S STAT=2,CANFLG=1,REASON=$P($P(^PSX(552.3,XX1,0),"\F",1),"|",4)
..I STAT="CO" S STAT=1 D
...I '$G(XX2) S ^XTMP("PSXBAD "_DT,XX1)=$G(TNODE) Q
...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"
...I $G(SHPDT) S SHPDT=$$HL7TFM^XLFDT(SHPDT)
..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)
..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
..K COMDT,STAT,REASON,PSXNDC,EMPID,COST,RXSTAT,BB,RXN,TDT,XDA,NPTR
..K PSXLOT,STAT1,STAT2,ZMPFLG,SHPDT,CARRIER,PKID,XX2
I '$O(^XTMP("PSXBAD "_DT,0)) K ^XTMP("PSXBAD "_DT,0)
FIN D EN^PSXVEND
D:CANFLG>0 CAN^PSXMSGS
S $P(^PSX(554,1,1,R554,0),U,4)="S"
D NDRGMSG^PSXRTN,NEXT^PSXRTN
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")
K LST,LSTQRY,QRYNQ,STOP,TNODE,XX0,XX1,R554,CANFLG,PSXTS,QRYN,QRYD
Q
FILE ;store the data in the RX multiple, PSX(515
K DD,DO,NREC,UU,VV,CC,X,AA,SS,CNT,LOT,EXPDT
Q:'$D(^PSX(552.1,"B",NPTR))
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"),"^")
S CC=$O(^PSX(552.4,"B",UU,"")) Q:'CC S NREC=CC
I '$D(^PSX(552.4,NREC,1,"B",RXN)) Q ;generate an error message that the rx doesn't exist
S XDA=$O(^PSX(552.4,NREC,1,"B",RXN,""))
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
.I $G(QRYD)>0 S DA=QRYD D ^DIE K DA,DR,DIE Q
S:$G(REASON)]"" REASON=$TR(REASON,"^"," ")
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)
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
LOCK L +^PSX(552.4,NREC):30 G:'$T LOCK
S DA=XDA,DA(1)=NREC,DIE="^PSX(552.4,"_NREC_",1,"
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)
S STAT2=".02////"_$G(COMDT)_";1////"_$G(STAT)_";2////^S X=$G(REASON);5////"_$G(EMPID)_";8////"_$G(QRYN)_";9////1;13////"_$G(RXSTAT)
S DR=$S($G(STAT)=1:STAT1,$G(STAT)=2:STAT2,1:"")
D ^DIE K DIE,DR,DA
L -^PSX(552.4,NREC)
K LOT,EXPDT,CNT
S SS=0 F S SS=$O(PSXLOT(SS)) Q:SS'>0 S CNT=SS D
.Q:$G(STAT)=2!($G(ZMPFLG)=1)
.S:'$D(^PSX(552.4,NREC,1,XDA,1,0)) ^PSX(552.4,NREC,1,XDA,1,0)="^552.56A^^"
.S LOT=$P(PSXLOT(CNT),U,1),PSXTS=$P(PSXLOT(CNT),U,2) D TSIN^PSXUTL S EXPDT=$P(PSXFM,".",1) K PSXTS,PSXFM
.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)
K SITE,REASON,UU,FACBAT,FILL,I,XYDA,IDDRG,IEN50
Q
ZMP Q:$P($G(TNODE),"|",7)=""
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,"
D ^DIE K DA,DR,DIE
D FILE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXRTN1 5538 printed Sep 23, 2025@19:21:03 Page 2
PSXRTN1 ;BIR/WPB,HTW-Background filer for V2 ;MAR 1,2002@16:11:17
+1 ;;2.0;CMOP;**1,2,14,23,32**;11 Apr 97
+2 ;Reference to ^PSDRUG( supported by DBIA #1983
DATA ;gets the data from PSX(513
+1 SET PSXZTSK=ZTSK
+2 SET R554=$ORDER(^PSX(554,"AB",""))
+3 IF $PIECE($GET(^PSX(554,1,1,R554,0)),U,4)="R"
DO NEXT^PSXRTN
QUIT
+4 SET $PIECE(^PSX(554,1,1,R554,0),U,4)="R"
EN KILL ^TMP($JOB,"PSXCAN"),XX0,ZZ,REC,TNODE
+1 SET X=$$FMADD^XLFDT(DT,+7)
SET ^XTMP("PSXBAD "_DT,0)=X_U_DT_U_"Vendor Missing NTE|100 segments"
+2 SET (CANFLG,STOP,ZMPFLG)=0
+3 SET LSTQRY=$ORDER(^PSX(553.2,"A"),-1)
+4 SET XX0=0
FOR
SET XX0=$ORDER(^PSX(552.3,"AQ",XX0))
if XX0'>0
QUIT
if STOP>0
GOTO FIN
SET TNODE=$GET(^PSX(552.3,XX0,0))
SET XX1=XX0+1
Begin DoDot:1
+5 IF $EXTRACT(TNODE,1,7)["NTE|100"
SET DA=XX0
SET DR="1////1"
SET DIE="^PSX(552.3,"
DO ^DIE
KILL DIE,DA,DR
QUIT
+6 IF $EXTRACT(TNODE,1,4)["PID|"
SET DA=XX0
SET DIE="^PSX(552.3,"
SET DR="1////1"
DO ^DIE
KILL DA,DR,DIE
QUIT
+7 IF $EXTRACT(TNODE,1,4)["MSA|"
SET QRYN=$PIECE(TNODE,"|",3)
SET DA=XX0
SET DR="1////1"
SET DIE="^PSX(552.3,"
DO ^DIE
KILL DA,DIE,DR
Begin DoDot:2
+8 IF $GET(QRYN)>0
if ($GET(QRYN)=LSTQRY)&($PIECE(^PSX(553.1,QRYN,0),"^",5)'=1)
SET STOP=1
End DoDot:2
QUIT
+9 if $GET(STOP)>0
QUIT
+10 if $GET(QRYN)'>0
SET QRYN=LSTQRY-1
+11 IF $EXTRACT(TNODE,1,3)["BTS"
SET DA=XX0
SET DR="1////1"
SET DIE="^PSX(552.3,"
DO ^DIE
KILL DA,DR,DIE,QRYD
QUIT
+12 IF $EXTRACT(TNODE,1,4)["QRD|"
SET PSXTS=$PIECE(TNODE,"|",2)
SET QRYN=$PIECE(TNODE,"|",5)
DO TSIN^PSXUTL
LOCK +^PSX(553.1,QRYN):30
SET QRYD=XX0
SET DA=QRYN
SET DIE="^PSX(553.1,"
SET DR="2////"_PSXFM
DO ^DIE
KILL DA,DR,DIE,PSXTS,PSXFM
LOCK -^PSX(553.1,QRYN)
Begin DoDot:2
+13 SET DA=XX0
SET DIE="^PSX(552.3,"
SET DR="1////1"
DO ^DIE
KILL DA,DIE,DR
End DoDot:2
QUIT
+14 IF $EXTRACT(TNODE,1,4)["ZMP|"
DO ZMP
SET ZMPFLG=1
QUIT
+15 IF $EXTRACT(TNODE,1,4)["MSH|"
SET DA=XX0
SET DR="1////1"
SET DIE="^PSX(552.3,"
DO ^DIE
KILL DA,DR,DIE
Begin DoDot:2
End DoDot:2
QUIT
+16 IF $EXTRACT(TNODE,1,8)["NTE|99||"
Begin DoDot:2
+17 ;S DA=XX0,DIE="^PSX(552.3,",DR="1////1" D ^DIE K DA,DR,DIE
+18 SET STAT=$PIECE(TNODE,"\",3)
SET RXN=$PIECE($PIECE(TNODE,"\",1),"|",4)
SET FACBAT=$PIECE($PIECE(TNODE,"\F\",6),"-",1,2)
+19 SET PSXTS=$PIECE(TNODE,"\",5)
DO TSIN^PSXUTL
SET COMDT=PSXFM
+20 SET EMPID=$PIECE(TNODE,"\",9)
SET RXSTAT=1
+21 SET PSXNDC=$PIECE(TNODE,"\",7)
+22 SET NPTR=$PIECE($PIECE(TNODE,"\",11),"-",1,2)
+23 ;flag for NTE|100 present
KILL XX2
if $GET(^PSX(552.3,XX1,0))["NTE|100"
SET XX2=XX1
+24 IF STAT="CA"
Begin DoDot:3
+25 IF '$GET(XX2)
SET ^XTMP("PSXBAD "_DT,XX1)=$GET(TNODE)
QUIT
+26 SET STAT=2
SET CANFLG=1
SET REASON=$PIECE($PIECE(^PSX(552.3,XX1,0),"\F",1),"|",4)
End DoDot:3
+27 IF STAT="CO"
SET STAT=1
Begin DoDot:3
+28 IF '$GET(XX2)
SET ^XTMP("PSXBAD "_DT,XX1)=$GET(TNODE)
QUIT
+29 SET SHPDT=$PIECE(^PSX(552.3,XX1,0),"\F\",2)
SET CARRIER=$PIECE(^PSX(552.3,XX1,0),"\F\",3)
SET PKID=$PIECE(^PSX(552.3,XX1,0),"\F\",4)
if $GET(CARRIER)=""
SET CARRIER="UNK"
+30 IF $GET(SHPDT)
SET SHPDT=$$HL7TFM^XLFDT(SHPDT)
End DoDot:3
+31 KILL PSXLOT
SET CC=0
FOR BB=13:4
if $PIECE(TNODE,"\",BB)=""
QUIT
SET CC=CC+1
SET PSXLOT(CC)=$PIECE(TNODE,"\",BB)_"^"_$PIECE(TNODE,"\",BB+2)
+32 DO FILE
SET DA=XX0
SET DIE="^PSX(552.3,"
SET DR="1////1"
DO ^DIE
KILL DA
IF $GET(XX2)
SET DA=XX2
DO ^DIE
KILL DA,DR,XX2,DIE
+33 KILL COMDT,STAT,REASON,PSXNDC,EMPID,COST,RXSTAT,BB,RXN,TDT,XDA,NPTR
+34 KILL PSXLOT,STAT1,STAT2,ZMPFLG,SHPDT,CARRIER,PKID,XX2
End DoDot:2
End DoDot:1
+35 IF '$ORDER(^XTMP("PSXBAD "_DT,0))
KILL ^XTMP("PSXBAD "_DT,0)
FIN DO EN^PSXVEND
+1 if CANFLG>0
DO CAN^PSXMSGS
+2 SET $PIECE(^PSX(554,1,1,R554,0),U,4)="S"
+3 DO NDRGMSG^PSXRTN
DO NEXT^PSXRTN
+4 IF $GET(^TMP($JOB,"PSXDUP"))'=""
SET XQAMSG="Duplicate release data received from the vendor system."
SET XQAROU="ALRT^PSXDRPT"
SET XQAID="PSX"
DO GRP1^PSXNOTE
DO SETUP^XQALERT
KILL ^TMP($JOB,"PSXDUP")
+5 KILL LST,LSTQRY,QRYNQ,STOP,TNODE,XX0,XX1,R554,CANFLG,PSXTS,QRYN,QRYD
+6 QUIT
FILE ;store the data in the RX multiple, PSX(515
+1 KILL DD,DO,NREC,UU,VV,CC,X,AA,SS,CNT,LOT,EXPDT
+2 if '$DATA(^PSX(552.1,"B",NPTR))
QUIT
+3 SET UU=$ORDER(^PSX(552.1,"B",NPTR,""))
if 'UU
QUIT
if $GET(STAT)=2
SET SITE=$PIECE($PIECE(^PSX(552.1,UU,0),"^",1),"-",1)
SET TDT=$PIECE(^PSX(552.1,UU,0),"^",3)
SET PSXDIV=$PIECE(^PSX(552.1,UU,"P"),"^")
+4 SET CC=$ORDER(^PSX(552.4,"B",UU,""))
if 'CC
QUIT
SET NREC=CC
+5 ;generate an error message that the rx doesn't exist
IF '$DATA(^PSX(552.4,NREC,1,"B",RXN))
QUIT
+6 SET XDA=$ORDER(^PSX(552.4,NREC,1,"B",RXN,""))
+7 IF $PIECE(^PSX(552.4,NREC,1,XDA,0),"^",9)'=""
SET ^TMP($JOB,"PSXDUP",RXN)=$GET(^PSX(552.3,XX0,0))
SET DA=XX0
SET DIE="^PSX(552.3,"
SET DR="1////3"
DO ^DIE
KILL DA
Begin DoDot:1
+8 IF $GET(QRYD)>0
SET DA=QRYD
DO ^DIE
KILL DA,DR,DIE
QUIT
End DoDot:1
QUIT
+9 if $GET(REASON)]""
SET REASON=$TRANSLATE(REASON,"^"," ")
+10 IF $GET(STAT)=2
SET FILL=$PIECE(^PSX(552.4,NREC,1,XDA,0),"^",12)
SET ^TMP($JOB,"PSXCAN",PSXDIV,SITE,RXN)=FACBAT_"^"_FILL_"^"_TDT_"^"_$GET(REASON)
+11 IF $GET(STAT)=1
SET IDDRG=$PIECE(^PSX(552.4,NREC,1,XDA,0),"^",4)
SET IEN50=$ORDER(^PSDRUG("AQ1",$GET(IDDRG),""))
if $GET(IEN50)'=""
SET COST=$PIECE(^PSDRUG($GET(IEN50),660),U,6)
if $GET(IEN50)=""!($GET(COST)="")
SET ^TMP($JOB,"PSXNDG",$GET(IDDRG),$GET(COMDT))=RXN_"^"_NPTR
LOCK LOCK +^PSX(552.4,NREC):30
if '$TEST
GOTO LOCK
+1 SET DA=XDA
SET DA(1)=NREC
SET DIE="^PSX(552.4,"_NREC_",1,"
+2 SET STAT1=".02////"_$GET(COMDT)_";1////"_$GET(STAT)_";4////"_$GET(PSXNDC)_";5////"_$GET(EMPID)_";8////"_$GET(QRYN)_";9////1;10////"_$GET(COST)_";13////"_$GET(RXSTAT)_";16////"_$GET(SHPDT)_";17////"_$GET(CARRIER)_";18////"_$GET(PKID)
+3 SET STAT2=".02////"_$GET(COMDT)_";1////"_$GET(STAT)_";2////^S X=$G(REASON);5////"_$GET(EMPID)_";8////"_$GET(QRYN)_";9////1;13////"_$GET(RXSTAT)
+4 SET DR=$SELECT($GET(STAT)=1:STAT1,$GET(STAT)=2:STAT2,1:"")
+5 DO ^DIE
KILL DIE,DR,DA
+6 LOCK -^PSX(552.4,NREC)
+7 KILL LOT,EXPDT,CNT
+8 SET SS=0
FOR
SET SS=$ORDER(PSXLOT(SS))
if SS'>0
QUIT
SET CNT=SS
Begin DoDot:1
+9 if $GET(STAT)=2!($GET(ZMPFLG)=1)
QUIT
+10 if '$DATA(^PSX(552.4,NREC,1,XDA,1,0))
SET ^PSX(552.4,NREC,1,XDA,1,0)="^552.56A^^"
+11 SET LOT=$PIECE(PSXLOT(CNT),U,1)
SET PSXTS=$PIECE(PSXLOT(CNT),U,2)
DO TSIN^PSXUTL
SET EXPDT=$PIECE(PSXFM,".",1)
KILL PSXTS,PSXFM
+12 SET DA(2)=NREC
SET DA(1)=XDA
SET X=LOT
SET DIC(0)="Z"
SET DIC="^PSX(552.4,"_NREC_",1,"_XDA_",1,"
SET DIC("DR")="1////"_EXPDT
DO FILE^DICN
KILL DIC,LOT,EXPDT,DA,DIC("DR"),DIC(0)
End DoDot:1
+13 KILL SITE,REASON,UU,FACBAT,FILL,I,XYDA,IDDRG,IEN50
+14 QUIT
ZMP if $PIECE($GET(TNODE),"|",7)=""
QUIT
+1 SET (FACBAT,NPTR)=$PIECE($PIECE(TNODE,"|",2),"-",1,2)
SET RXN=$PIECE(TNODE,"|",3)
SET STAT=$SELECT($PIECE(^PSX(552.3,XX0,0),"|",9)'="":2,1:"1")
SET REASON=$PIECE(TNODE,"|",9)
SET EMPID=$PIECE(TNODE,"|",8)
SET COMDT=$PIECE(TNODE,"|",7)
SET RXSTAT=2
SET DA=XX0
SET DR="1////1"
SET DIE="^PSX(552.3,"
+2 DO ^DIE
KILL DA,DR,DIE
+3 DO FILE
+4 QUIT
