- 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 Mar 13, 2025@20:49:43 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