Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSXRTN1

PSXRTN1.m

Go to the documentation of this file.
  1. 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
  1. ;Reference to ^PSDRUG( supported by DBIA #1983
  1. DATA ;gets the data from PSX(513
  1. S PSXZTSK=ZTSK
  1. S R554=$O(^PSX(554,"AB",""))
  1. I $P($G(^PSX(554,1,1,R554,0)),U,4)="R" D NEXT^PSXRTN Q
  1. S $P(^PSX(554,1,1,R554,0),U,4)="R"
  1. EN K ^TMP($J,"PSXCAN"),XX0,ZZ,REC,TNODE
  1. S X=$$FMADD^XLFDT(DT,+7),^XTMP("PSXBAD "_DT,0)=X_U_DT_U_"Vendor Missing NTE|100 segments"
  1. S (CANFLG,STOP,ZMPFLG)=0
  1. S LSTQRY=$O(^PSX(553.2,"A"),-1)
  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
  1. .I $E(TNODE,1,7)["NTE|100" S DA=XX0,DR="1////1",DIE="^PSX(552.3," D ^DIE K DIE,DA,DR Q
  1. .I $E(TNODE,1,4)["PID|" S DA=XX0,DIE="^PSX(552.3,",DR="1////1" D ^DIE K DA,DR,DIE Q
  1. .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
  1. ..I $G(QRYN)>0 S:($G(QRYN)=LSTQRY)&($P(^PSX(553.1,QRYN,0),"^",5)'=1) STOP=1
  1. .Q:$G(STOP)>0
  1. .S:$G(QRYN)'>0 QRYN=LSTQRY-1
  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
  1. .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
  1. ..S DA=XX0,DIE="^PSX(552.3,",DR="1////1" D ^DIE K DA,DIE,DR
  1. .I $E(TNODE,1,4)["ZMP|" D ZMP S ZMPFLG=1 Q
  1. .I $E(TNODE,1,4)["MSH|" S DA=XX0,DR="1////1",DIE="^PSX(552.3," D ^DIE K DA,DR,DIE D Q
  1. .I $E(TNODE,1,8)["NTE|99||" D
  1. ..;S DA=XX0,DIE="^PSX(552.3,",DR="1////1" D ^DIE K DA,DR,DIE
  1. ..S STAT=$P(TNODE,"\",3),RXN=$P($P(TNODE,"\",1),"|",4),FACBAT=$P($P(TNODE,"\F\",6),"-",1,2)
  1. ..S PSXTS=$P(TNODE,"\",5) D TSIN^PSXUTL S COMDT=PSXFM
  1. ..S EMPID=$P(TNODE,"\",9),RXSTAT=1
  1. ..S PSXNDC=$P(TNODE,"\",7)
  1. ..S NPTR=$P($P(TNODE,"\",11),"-",1,2)
  1. ..K XX2 S:$G(^PSX(552.3,XX1,0))["NTE|100" XX2=XX1 ;flag for NTE|100 present
  1. ..I STAT="CA" D
  1. ...I '$G(XX2) S ^XTMP("PSXBAD "_DT,XX1)=$G(TNODE) Q
  1. ...S STAT=2,CANFLG=1,REASON=$P($P(^PSX(552.3,XX1,0),"\F",1),"|",4)
  1. ..I STAT="CO" S STAT=1 D
  1. ...I '$G(XX2) S ^XTMP("PSXBAD "_DT,XX1)=$G(TNODE) Q
  1. ...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"
  1. ...I $G(SHPDT) S SHPDT=$$HL7TFM^XLFDT(SHPDT)
  1. ..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)
  1. ..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
  1. ..K COMDT,STAT,REASON,PSXNDC,EMPID,COST,RXSTAT,BB,RXN,TDT,XDA,NPTR
  1. ..K PSXLOT,STAT1,STAT2,ZMPFLG,SHPDT,CARRIER,PKID,XX2
  1. I '$O(^XTMP("PSXBAD "_DT,0)) K ^XTMP("PSXBAD "_DT,0)
  1. FIN D EN^PSXVEND
  1. D:CANFLG>0 CAN^PSXMSGS
  1. S $P(^PSX(554,1,1,R554,0),U,4)="S"
  1. D NDRGMSG^PSXRTN,NEXT^PSXRTN
  1. 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")
  1. K LST,LSTQRY,QRYNQ,STOP,TNODE,XX0,XX1,R554,CANFLG,PSXTS,QRYN,QRYD
  1. Q
  1. FILE ;store the data in the RX multiple, PSX(515
  1. K DD,DO,NREC,UU,VV,CC,X,AA,SS,CNT,LOT,EXPDT
  1. Q:'$D(^PSX(552.1,"B",NPTR))
  1. 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"),"^")
  1. S CC=$O(^PSX(552.4,"B",UU,"")) Q:'CC S NREC=CC
  1. I '$D(^PSX(552.4,NREC,1,"B",RXN)) Q ;generate an error message that the rx doesn't exist
  1. S XDA=$O(^PSX(552.4,NREC,1,"B",RXN,""))
  1. 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
  1. .I $G(QRYD)>0 S DA=QRYD D ^DIE K DA,DR,DIE Q
  1. S:$G(REASON)]"" REASON=$TR(REASON,"^"," ")
  1. 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)
  1. 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
  1. LOCK L +^PSX(552.4,NREC):30 G:'$T LOCK
  1. S DA=XDA,DA(1)=NREC,DIE="^PSX(552.4,"_NREC_",1,"
  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)
  1. S STAT2=".02////"_$G(COMDT)_";1////"_$G(STAT)_";2////^S X=$G(REASON);5////"_$G(EMPID)_";8////"_$G(QRYN)_";9////1;13////"_$G(RXSTAT)
  1. S DR=$S($G(STAT)=1:STAT1,$G(STAT)=2:STAT2,1:"")
  1. D ^DIE K DIE,DR,DA
  1. L -^PSX(552.4,NREC)
  1. K LOT,EXPDT,CNT
  1. S SS=0 F S SS=$O(PSXLOT(SS)) Q:SS'>0 S CNT=SS D
  1. .Q:$G(STAT)=2!($G(ZMPFLG)=1)
  1. .S:'$D(^PSX(552.4,NREC,1,XDA,1,0)) ^PSX(552.4,NREC,1,XDA,1,0)="^552.56A^^"
  1. .S LOT=$P(PSXLOT(CNT),U,1),PSXTS=$P(PSXLOT(CNT),U,2) D TSIN^PSXUTL S EXPDT=$P(PSXFM,".",1) K PSXTS,PSXFM
  1. .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)
  1. K SITE,REASON,UU,FACBAT,FILL,I,XYDA,IDDRG,IEN50
  1. Q
  1. ZMP Q:$P($G(TNODE),"|",7)=""
  1. 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,"
  1. D ^DIE K DA,DR,DIE
  1. D FILE
  1. Q