PSXVND ;BIR/WPB,HTW,PWC-File Release Data at the Remote Facility ;20-Jun-2013 17:16;PLS
;;2.0;CMOP;**1,2,4,5,14,18,19,15,24,23,27,35,39,36,1008,1009,48,62,58,1015**;11 Apr 97;Build 62
;Reference to ^PSDRUG( supported by DBIA #1983
;Reference to ^PSRX( supported by DBIA #1977
;Reference to ^PS(59 supported by DBIA #1976
;Reference to routine CP^PSOCP supported by DBIA #1974
;Reference to routine EN^PSOHLSN1 supported by DBIA #2385
;Reference to routine EN^RGEQ supported by DBIA #2382
;Reference to routine AUTOREL^PSOBPSUT supported by DBIA #4701
;Called by Taskman to handle release data
;Modified - IHS/MSC/PLS - 09/18/2009 - Line PAR (several)
; - Line GET+30
; IHS/MSC/PB - 11/14/2012 - TMP+3 modified to use the variable FAC to allow for multidivisional processing of Rxs
; IHS/MSC/PLS - 06/20/2013 - Line GET+32
EN H 5 S CNT=1,FROM=XMFROM,ZTREQ="@"
S DOMAIN=$S($P(XMFROM,"@",2)'="":"@"_$P(FROM,"@",2),$P(XMFROM,"@",2)="":"",1:""),XMSER="S."_XQSOP,TXMZ=XQMSG
S (X,SITE,DA)=$$KSP^XUPARAM("INST"),DIC="4",DIQ(0)="IE",DR=99,DIQ="PSXUTIL" D EN^DIQ1 S HERE=$G(PSXUTIL(4,SITE,99,"I")) K DA,DIC,DIQ(0),DR
F X XMREC I $G(XMRG)'="" S TXMRG=XMRG G:$G(XMER)<0 EXIT1 D:$E(XMRG,1,3)["$RX" GET G:$E(XMRG,1,5)["$$END" MAIL D:$E(XMRG,1,4)["$LOT" LOT S:$E(XMRG,1,5)["$$VND" MSNUM=$P(XMRG,"^",3)
G EXIT
GET Q:$G(XMRG)=""!($E(XMRG,1,3)'["$RX")
K FACBAT,BAT,NDC,RELDT,STAT,REASON,XFILL,P515A,P515B,%,RR,ALOT,RXP,RXN,FLAG,FILL,RELD,ZSTAT,RTN,CARRIER,PKGID,SHPDT
S RX=$P(XMRG,U,2),FACBAT=$P(XMRG,U,3),BAT=$P(FACBAT,"-",2),NDC=$P(XMRG,U,4),RELDT=$P(XMRG,U,5),STAT=$P(XMRG,U,6),REASON=$P($G(XMRG),U,8),XFILL=$P($G(XMRG),U,7)
S P515A=$P(XMRG,U,9),P515B=$P(XMRG,U,10),DRG=$P(XMRG,U,12),QTY=$P(XMRG,U,11),CARRIER=$P(XMRG,U,13),PKGID=$P(XMRG,U,14),SHPDT=$P(XMRG,U,15)
S FAC=$P(FACBAT,"-",1)
;Q:FAC'=HERE ; IHS/MSC/PLS - 11/14/2012 - 1015
I '$O(^PSRX("B",RX,0)) S FLAG=2 D TMP Q
S XX=0 F S XX=$O(^PSRX("B",RX,XX)) Q:XX'>0 S (RXP,RXN)=XX,FLAG=0 D
.I '$G(BAT) Q
.I '$D(^PSRX(RXN,0)) S FLAG=2 D TMP Q
.L +^PSRX(RXN):DTIME I '$T S FLAG=2 D TMP Q
.I XFILL>0,('$D(^PSRX(RXN,1,XFILL,0))) S FLAG=6 D TMP Q
.I XFILL>0,($P(^PSRX(RXP,1,XFILL,0),"^",18)'="") S FLAG=1,RLDT=$P(^PSRX(RXP,1,XFILL,0),"^",18) S:STAT=1&(RLDT=RELDT) FLAG=0 D:FLAG=0 TMP1 Q:'$G(FLAG) D:FLAG=1 TMP Q
.I XFILL=0,($P(^PSRX(RXP,2),"^",13)'="") S FLAG=1,RLDT=$P(^PSRX(RXP,2),"^",13) S:STAT=1&(RELDT=RLDT) FLAG=0 D:FLAG=0 TMP1 Q:'$G(FLAG) D:FLAG=1 TMP Q
.I STAT=2 D
..S RXDRG=$P(^PSRX(RXN,0),"^",6),DFN=$P(^PSRX(RXN,0),"^",2)
..I $G(RXDRG)]"" S CMOPNM=$P($G(^PSDRUG(RXDRG,0)),"^")
..I '$D(^PSDRUG("AQ",RXDRG)) S CMOPYN=1
..I $D(^PSDRUG(RXDRG,"ND")) S CMOPID=$P($G(^PSDRUG(RXDRG,"ND")),"^",10)
..S DIV=$S(XFILL=0:$P(^PSRX(RXN,2),U,9),XFILL>0:$P(^PSRX(RXN,1,XFILL,0),U,9),1:"")
..S ^TMP("PSXCAN1",$J,DIV,DFN,RX)=$G(CMOPNM)_U_$G(CMOPID)_U_$G(QTY)_U_$G(DRG)_U_$G(CMOPYN)_U_REASON_U_$G(XFILL)_U_$G(BAT)
..K CMOPNM,CMOPID,DRG,RXDRG,MATCH,CMOPYN,NDF1,NDF2,P1,P2,PSDDA
.I '$D(^PSRX(RXN,4,0)) S FLAG=5 D TMP Q
.I '$D(^PSRX(RXN,4,"B",BAT)) S FLAG=4 D TMP Q
.I $D(^PSRX(RXN,4,"B",BAT)) S RECD=$O(^PSRX(RXN,4,"B",BAT,"")),FILL=$P($G(^PSRX(RXN,4,RECD,0)),U,3),ZSTAT=$P(^PSRX(RXN,4,RECD,0),U,4)
.I ZSTAT=2 S RTN=0 F S RTN=$O(^PSRX(RXN,4,RTN)) Q:RTN'>0 I $P(^PSRX(RXN,4,RTN,0),U,3)=FILL&($P(^PSRX(RXN,4,RTN,0),U,1)'=BAT) S DA(1)=RXN,DA=RTN,DIE="^PSRX("_DA(1)_",4,",DR="3////2;8////FILLED IN TRANSMISSION "_BAT D ^DIE K DA,DR,DIE
.I FILL'=XFILL S FLAG=3 D TMP Q
.S PSXREF=FILL
.Q:FLAG>0
.S PSXXMZ=XMZ
.N PSOSITE ;PATCH 1008
.D:$G(STAT)=1
..;N PSOPAR,PSOSITE,X D NOW^%DTC
..N PSOPAR,X D NOW^%DTC ;IHS/MSC/PLS - 06/20/13
..I $G(PSXREF)>0 S PSOSITE=$P(^PSRX(RXP,1,PSXREF,0),"^",9) G:$G(PSOSITE) PAR
..S PSOSITE=$P(^PSRX(RXP,2),"^",9),PSQUIT=0
..I '$G(PSOSITE) S Z1=0 F S Z1=$O(^PS(59,Z1)) Q:Z1=""!(Z1="B") D Q:PSQUIT
...I $D(^PS(59,Z1,"I"))&($P($G(^PS(59,Z1,"I")),"^")'="") Q:$P($G(^PS(59,Z1,"I")),"^")'>X
...S PSOSITE=Z1,PSQUIT=1
..Q:'$G(PSOSITE)
PAR ..S PSOPAR=$G(^PS(59,PSOSITE,1))
..I $G(PSXREF)>0 S YY=PSXREF
..I '$G(PSOSITE)!('$D(PSOPAR)) Q
..D CP^PSOCP K YY,X
.S XMZ=PSXXMZ
.I $G(FILL)="" Q
.I $G(STAT)=1 D
..;I FILL=0 S DA=RXN,DIE="^PSRX(",DR="31///"_RELDT D ^DIE K DIE,DA,DR
..I FILL=0 S DA=RXN,DIE="^PSRX(",DR="31///"_RELDT_";22///"_$P(RELDT,".")_";25///"_$P(RELDT,".")_";27///"_$$FIXNDC(NDC) D ^DIE K DIE,DA,DR
..;I FILL>0 S DA(1)=RXN,DA=FILL,DIE="^PSRX("_RXN_",1,",DR="17///"_RELDT_";10.1///"_RELDT D ^DIE K DIE,DR,DA
..I FILL>0 D
...S DA(1)=RXN,DA=FILL,DIE="^PSRX("_RXN_",1,",DR="17///"_RELDT_";10.1///"_RELDT_";.01///"_$P(RELDT,".")_";11///"_$$FIXNDC(NDC) D ^DIE K DIE,DR,DA
...S DA=RXN,DIE="^PSRX(",DR="101///"_$P(RELDT,".") D ^DIE K DIE,DA,DR
..D CALLPOS^APSPFUNC(RXN,$S(XFILL:XFILL,1:""),"A") ;IHS/MSC/PLS - 05/28/09
..; I $$VERSION^XPDUTL("OUTPATIENT PHARMACY")<7 S X="RGEQ" X ^%ZOSF("TEST") I D EN^RGEQ("RX",RXN) ;CIRN
..I $$VERSION^XPDUTL("OUTPATIENT PHARMACY")>6 D EN^PSOHLSN1(RXN,"ZD")
.S DA(1)=RXN,DA=RECD,DIE="^PSRX("_RXN_",4,"
.S DR="3////"_$S(STAT=2:3,STAT=1:1,1:"")_";4////"_NDC_";5////"_$S(STAT=2:RELDT,STAT=1:"",1:"")_";8////"_$S(STAT=2:"^S X=$G(REASON)",STAT=1:"",1:"")_";10////"_$G(CARRIER)_";11////"_$G(PKGID)_";9////"_$G(SHPDT)
.D ^DIE K DIE,DA,DR
.I $$PATCH^XPDUTL("PSO*7.0*148") D AUTOREL^PSOBPSUT(RXN,FILL,RELDT,NDC,"C",$S(STAT=1:"S",1:"U"),60)
I $D(^PSRX(RXN)) L -^PSRX(RXN):0
TMP1 Q:$G(FLAG)'=0!('$G(BAT))
D NOW^%DTC S PSXTM=%
;next line modified to use variable FAC instead of HERE to allow for multidivisional processing
;S ^TMP($J,"PSXREL",CNT)=RX_"^"_PSXTM_"^"_P515A_"^"_P515B_"^"_XFILL_"^"_HERE
S ^TMP($J,"PSXREL",CNT)=RX_"^"_PSXTM_"^"_P515A_"^"_P515B_"^"_XFILL_"^"_FAC
S CNT=CNT+1
Q
;
LOT S ALOT=$P(XMRG,"|",2)
I $G(ALOT)'="" D
.K DD,DO
.S:'$D(^PSRX(RXN,5,0)) ^PSRX(RXN,5,0)="^52.0401A^^"
.F RR=1:1 Q:$P(ALOT,"\",RR)="" S LOT1=$P(ALOT,"\",RR),LOT=$P(LOT1,"^",1),EXDT=$P(LOT1,"^",2) D
..S DA(1)=RXN,X=LOT,DIC="^PSRX("_RXN_",5,",DIC("DR")="1////"_EXDT_";2////"_XFILL,DIC(0)="Z"
FF ..D FILE^DICN K DIC("DR"),DIC,DA,LOT,EXDT,DD,DO
Q
TMP S ^TMP($J,"PSXVND",RX)=FLAG_"^"_XFILL_"^"_P515A_"^"_P515B_"^"_HERE_"^"_$S(FLAG=1:RLDT,1:"") Q
MAIL S XMSUB="CMOP Release Data Acknowledgement",LCNT=1,XMDUZ=.5
MM D XMZ^XMA2 G:XMZ<1 MM
S ^XMB(3.9,XMZ,2,LCNT,0)="$$RTN^"_MSNUM_"^"_HERE,LCNT=LCNT+1
F CC=0:0 S CC=$O(^TMP($J,"PSXREL",CC)) Q:CC'>0 D
.S ^XMB(3.9,XMZ,2,LCNT,0)="$RX^"_$G(^TMP($J,"PSXREL",CC)),LCNT=LCNT+1
S ^XMB(3.9,XMZ,2,LCNT,0)="$$INV"
S CC="" F S CC=$O(^TMP($J,"PSXVND",CC)) Q:CC="" S RXN=CC D
.S LCNT=LCNT+1 D NOW^%DTC S PSXTM=% ;added for PSX*2*36
.S ^XMB(3.9,XMZ,2,LCNT,0)="$RXN"_"^"_RXN_"^"_$G(^TMP($J,"PSXVND",CC))_"^"_PSXTM
S ^XMB(3.9,XMZ,2,LCNT+1,0)="$$ENDINV"
S ^XMB(3.9,XMZ,2,0)="^3.92A^"_LCNT_U_LCNT_U_DT,XMDUN="CMOP Manager"
K XMY S XMY("S.PSXX CMOP SERVER"_DOMAIN)="" D ENT1^XMD
;D ER6^PSXERR Q
D:$D(^TMP("PSXCAN1",$J)) CAN^PSXMSGS
EXIT S XMSER="S.PSXX CMOP SERVER",XMZ=TXMZ D REMSBMSG^XMA1C
EXIT1 K XMSUB,XMDUZ,XMDUN,XMY,LCNT,XMZ,CC,PSXREL,CNT,Y,X,RR,LOT,LOT1,EXDT,ALOT
K RXN,RX,DLAYGO,FACBAT,FILL,FROM,NDC,P514,REASON,RELDT,STAT,XMREC,XMRG
K ^TMP($J,"PSXVND"),^TMP($J,"PSXREL"),RLDT,FLAG,TXMRG,PSXXMZ,ZSTAT,PSXTM
K XQMSG,XQSOP,XX,ZZZ,%,DAT,DOMAIN,PSXJOB,PSXREF,RECD,RXP,TXMZ,XMZ,XMER
K XMFROM,XMSER,BAT,PSXREFL,XFILL,FAC,HERE,P515A,P515B,SITE,MSNUM
K DIQ,DIV,QTY,PSXUTIL,SHPDT,Z1,PSQUIT
Q
; Return IHS formatted NDC value
FIXNDC(NDC) ; EP
S:$L(NDC)=11 NDC=$E(NDC,1,5)_"-"_$E(NDC,6,9)_"-"_$E(NDC,10,11)
Q NDC
PSXVND ;BIR/WPB,HTW,PWC-File Release Data at the Remote Facility ;20-Jun-2013 17:16;PLS
+1 ;;2.0;CMOP;**1,2,4,5,14,18,19,15,24,23,27,35,39,36,1008,1009,48,62,58,1015**;11 Apr 97;Build 62
+2 ;Reference to ^PSDRUG( supported by DBIA #1983
+3 ;Reference to ^PSRX( supported by DBIA #1977
+4 ;Reference to ^PS(59 supported by DBIA #1976
+5 ;Reference to routine CP^PSOCP supported by DBIA #1974
+6 ;Reference to routine EN^PSOHLSN1 supported by DBIA #2385
+7 ;Reference to routine EN^RGEQ supported by DBIA #2382
+8 ;Reference to routine AUTOREL^PSOBPSUT supported by DBIA #4701
+9 ;Called by Taskman to handle release data
+10 ;Modified - IHS/MSC/PLS - 09/18/2009 - Line PAR (several)
+11 ; - Line GET+30
+12 ; IHS/MSC/PB - 11/14/2012 - TMP+3 modified to use the variable FAC to allow for multidivisional processing of Rxs
+13 ; IHS/MSC/PLS - 06/20/2013 - Line GET+32
EN HANG 5
SET CNT=1
SET FROM=XMFROM
SET ZTREQ="@"
+1 SET DOMAIN=$SELECT($PIECE(XMFROM,"@",2)'="":"@"_$PIECE(FROM,"@",2),$PIECE(XMFROM,"@",2)="":"",1:"")
SET XMSER="S."_XQSOP
SET TXMZ=XQMSG
+2 SET (X,SITE,DA)=$$KSP^XUPARAM("INST")
SET DIC="4"
SET DIQ(0)="IE"
SET DR=99
SET DIQ="PSXUTIL"
DO EN^DIQ1
SET HERE=$GET(PSXUTIL(4,SITE,99,"I"))
KILL DA,DIC,DIQ(0),DR
+3 FOR
XECUTE XMREC
IF $GET(XMRG)'=""
SET TXMRG=XMRG
IF $GET(XMER)<0
GOTO EXIT1
IF $EXTRACT(XMRG,1,3)["$RX"
DO GET
IF $EXTRACT(XMRG,1,5)["$$END"
GOTO MAIL
IF $EXTRACT(XMRG,1,4)["$LOT"
DO LOT
IF $EXTRACT(XMRG,1,5)["$$VND"
SET MSNUM=$PIECE(XMRG,"^",3)
+4 GOTO EXIT
GET IF $GET(XMRG)=""!($EXTRACT(XMRG,1,3)'["$RX")
QUIT
+1 KILL FACBAT,BAT,NDC,RELDT,STAT,REASON,XFILL,P515A,P515B,%,RR,ALOT,RXP,RXN,FLAG,FILL,RELD,ZSTAT,RTN,CARRIER,PKGID,SHPDT
+2 SET RX=$PIECE(XMRG,U,2)
SET FACBAT=$PIECE(XMRG,U,3)
SET BAT=$PIECE(FACBAT,"-",2)
SET NDC=$PIECE(XMRG,U,4)
SET RELDT=$PIECE(XMRG,U,5)
SET STAT=$PIECE(XMRG,U,6)
SET REASON=$PIECE($GET(XMRG),U,8)
SET XFILL=$PIECE($GET(XMRG),U,7)
+3 SET P515A=$PIECE(XMRG,U,9)
SET P515B=$PIECE(XMRG,U,10)
SET DRG=$PIECE(XMRG,U,12)
SET QTY=$PIECE(XMRG,U,11)
SET CARRIER=$PIECE(XMRG,U,13)
SET PKGID=$PIECE(XMRG,U,14)
SET SHPDT=$PIECE(XMRG,U,15)
+4 SET FAC=$PIECE(FACBAT,"-",1)
+5 ;Q:FAC'=HERE ; IHS/MSC/PLS - 11/14/2012 - 1015
+6 IF '$ORDER(^PSRX("B",RX,0))
SET FLAG=2
DO TMP
QUIT
+7 SET XX=0
FOR
SET XX=$ORDER(^PSRX("B",RX,XX))
IF XX'>0
QUIT
SET (RXP,RXN)=XX
SET FLAG=0
Begin DoDot:1
+8 IF '$GET(BAT)
QUIT
+9 IF '$DATA(^PSRX(RXN,0))
SET FLAG=2
DO TMP
QUIT
+10 LOCK +^PSRX(RXN):DTIME
IF '$TEST
SET FLAG=2
DO TMP
QUIT
+11 IF XFILL>0
IF ('$DATA(^PSRX(RXN,1,XFILL,0)))
SET FLAG=6
DO TMP
QUIT
+12 IF XFILL>0
IF ($PIECE(^PSRX(RXP,1,XFILL,0),"^",18)'="")
SET FLAG=1
SET RLDT=$PIECE(^PSRX(RXP,1,XFILL,0),"^",18)
IF STAT=1&(RLDT=RELDT)
SET FLAG=0
IF FLAG=0
DO TMP1
IF '$GET(FLAG)
QUIT
IF FLAG=1
DO TMP
QUIT
+13 IF XFILL=0
IF ($PIECE(^PSRX(RXP,2),"^",13)'="")
SET FLAG=1
SET RLDT=$PIECE(^PSRX(RXP,2),"^",13)
IF STAT=1&(RELDT=RLDT)
SET FLAG=0
IF FLAG=0
DO TMP1
IF '$GET(FLAG)
QUIT
IF FLAG=1
DO TMP
QUIT
+14 IF STAT=2
Begin DoDot:2
+15 SET RXDRG=$PIECE(^PSRX(RXN,0),"^",6)
SET DFN=$PIECE(^PSRX(RXN,0),"^",2)
+16 IF $GET(RXDRG)]""
SET CMOPNM=$PIECE($GET(^PSDRUG(RXDRG,0)),"^")
+17 IF '$DATA(^PSDRUG("AQ",RXDRG))
SET CMOPYN=1
+18 IF $DATA(^PSDRUG(RXDRG,"ND"))
SET CMOPID=$PIECE($GET(^PSDRUG(RXDRG,"ND")),"^",10)
+19 SET DIV=$SELECT(XFILL=0:$PIECE(^PSRX(RXN,2),U,9),XFILL>0:$PIECE(^PSRX(RXN,1,XFILL,0),U,9),1:"")
+20 SET ^TMP("PSXCAN1",$JOB,DIV,DFN,RX)=$GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET(CMOPNM)_U_$GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET(CMOPID)_U_$GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET(QTY)_U_$GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET(DRG)_U_$GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET(CMOPYN)_U_REASON_U_$GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET(XFILL)_U_$GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET">GET(BAT)
+21 KILL CMOPNM,CMOPID,DRG,RXDRG,MATCH,CMOPYN,NDF1,NDF2,P1,P2,PSDDA
End DoDot:2
+22 IF '$DATA(^PSRX(RXN,4,0))
SET FLAG=5
DO TMP
QUIT
+23 IF '$DATA(^PSRX(RXN,4,"B",BAT))
SET FLAG=4
DO TMP
QUIT
+24 IF $DATA(^PSRX(RXN,4,"B",BAT))
SET RECD=$ORDER(^PSRX(RXN,4,"B",BAT,""))
SET FILL=$PIECE($GET(^PSRX(RXN,4,RECD,0)),U,3)
SET ZSTAT=$PIECE(^PSRX(RXN,4,RECD,0),U,4)
+25 IF ZSTAT=2
SET RTN=0
FOR
SET RTN=$ORDER(^PSRX(RXN,4,RTN))
IF RTN'>0
QUIT
IF $PIECE(^PSRX(RXN,4,RTN,0),U,3)=FILL&($PIECE(^PSRX(RXN,4,RTN,0),U,1)'=BAT)
SET DA(1)=RXN
SET DA=RTN
SET DIE="^PSRX("_DA(1)_",4,"
SET DR="3////2;8////FILLED IN TRANSMISSION "_BAT
DO ^DIE
KILL DA,DR,DIE
+26 IF FILL'=XFILL
SET FLAG=3
DO TMP
QUIT
+27 SET PSXREF=FILL
+28 IF FLAG>0
QUIT
+29 SET PSXXMZ=XMZ
+30 ;PATCH 1008
NEW PSOSITE
+31 IF $GET(STAT)=1
Begin DoDot:2
+32 ;N PSOPAR,PSOSITE,X D NOW^%DTC
+33 ;IHS/MSC/PLS - 06/20/13
NEW PSOPAR,X
DO NOW^%DTC
+34 IF $GET(PSXREF)>0
SET PSOSITE=$PIECE(^PSRX(RXP,1,PSXREF,0),"^",9)
IF $GET(PSOSITE)
GOTO PAR
+35 SET PSOSITE=$PIECE(^PSRX(RXP,2),"^",9)
SET PSQUIT=0
+36 IF '$GET(PSOSITE)
SET Z1=0
FOR
SET Z1=$ORDER(^PS(59,Z1))
IF Z1=""!(Z1="B")
QUIT
Begin DoDot:3
+37 IF $DATA(^PS(59,Z1,"I"))&($PIECE($GET(^PS(59,Z1,"I")),"^")'="")
IF $PIECE($GET(^PS(59,Z1,"I")),"^")'>X
QUIT
+38 SET PSOSITE=Z1
SET PSQUIT=1
End DoDot:3
IF PSQUIT
QUIT
+39 IF '$GET(PSOSITE)
QUIT
PAR SET PSOPAR=$GET(^PS(59,PSOSITE,1))
+1 IF $GET(PSXREF)>0
SET YY=PSXREF
+2 IF '$GET(PSOSITE)!('$DATA(PSOPAR))
QUIT
+3 DO CP^PSOCP
KILL YY,X
End DoDot:2
+4 SET XMZ=PSXXMZ
+5 IF $GET(FILL)=""
QUIT
+6 IF $GET(STAT)=1
Begin DoDot:2
+7 ;I FILL=0 S DA=RXN,DIE="^PSRX(",DR="31///"_RELDT D ^DIE K DIE,DA,DR
+8 IF FILL=0
SET DA=RXN
SET DIE="^PSRX("
SET DR="31///"_RELDT_";22///"_$PIECE(RELDT,".")_";25///"_$PIECE(RELDT,".")_";27///"_$$FIXNDC(NDC)
DO ^DIE
KILL DIE,DA,DR
+9 ;I FILL>0 S DA(1)=RXN,DA=FILL,DIE="^PSRX("_RXN_",1,",DR="17///"_RELDT_";10.1///"_RELDT D ^DIE K DIE,DR,DA
+10 IF FILL>0
Begin DoDot:3
+11 SET DA(1)=RXN
SET DA=FILL
SET DIE="^PSRX("_RXN_",1,"
SET DR="17///"_RELDT_";10.1///"_RELDT_";.01///"_$PIECE(RELDT,".")_";11///"_$$FIXNDC(NDC)
DO ^DIE
KILL DIE,DR,DA
+12 SET DA=RXN
SET DIE="^PSRX("
SET DR="101///"_$PIECE(RELDT,".")
DO ^DIE
KILL DIE,DA,DR
End DoDot:3
+13 ;IHS/MSC/PLS - 05/28/09
DO CALLPOS^APSPFUNC(RXN,$SELECT(XFILL:XFILL,1:""),"A")
+14 ; I $$VERSION^XPDUTL("OUTPATIENT PHARMACY")<7 S X="RGEQ" X ^%ZOSF("TEST") I D EN^RGEQ("RX",RXN) ;CIRN
+15 IF $$VERSION^XPDUTL("OUTPATIENT PHARMACY")>6
DO EN^PSOHLSN1(RXN,"ZD")
End DoDot:2
+16 SET DA(1)=RXN
SET DA=RECD
SET DIE="^PSRX("_RXN_",4,"
+17 SET DR="3////"_$SELECT(STAT=2:3,STAT=1:1,1:"")_";4////"_NDC_";5////"_$SELECT(STAT=2:RELDT,STAT=1:"",1:"")_";8////"_$SELECT(STAT=2:"^S X=$G(REASON)",STAT=1:"",1:"")_";10////"_$GET">GET">GET">GET(CARRIER)_";11////"_$GET">GET">GET">GET(PKGID)_";9////"_$GET">GET">GET">GET(SHPDT)
+18 DO ^DIE
KILL DIE,DA,DR
+19 IF $$PATCH^XPDUTL("PSO*7.0*148")
DO AUTOREL^PSOBPSUT(RXN,FILL,RELDT,NDC,"C",$SELECT(STAT=1:"S",1:"U"),60)
End DoDot:1
+20 IF $DATA(^PSRX(RXN))
LOCK -^PSRX(RXN):0
TMP1 IF $GET">GET(FLAG)'=0!('$GET">GET(BAT))
QUIT
+1 DO NOW^%DTC
SET PSXTM=%
+2 ;next line modified to use variable FAC instead of HERE to allow for multidivisional processing
+3 ;S ^TMP($J,"PSXREL",CNT)=RX_"^"_PSXTM_"^"_P515A_"^"_P515B_"^"_XFILL_"^"_HERE
+4 SET ^TMP($JOB,"PSXREL",CNT)=RX_"^"_PSXTM_"^"_P515A_"^"_P515B_"^"_XFILL_"^"_FAC
+5 SET CNT=CNT+1
+6 QUIT
+7 ;
LOT SET ALOT=$PIECE(XMRG,"|",2)
+1 IF $GET(ALOT)'=""
Begin DoDot:1
+2 KILL DD,DO
+3 IF '$DATA(^PSRX(RXN,5,0))
SET ^PSRX(RXN,5,0)="^52.0401A^^"
+4 FOR RR=1:1
IF $PIECE(ALOT,"\",RR)=""
QUIT
SET LOT1=$PIECE(ALOT,"\",RR)
SET LOT=$PIECE(LOT1,"^",1)
SET EXDT=$PIECE(LOT1,"^",2)
Begin DoDot:2
+5 SET DA(1)=RXN
SET X=LOT
SET DIC="^PSRX("_RXN_",5,"
SET DIC("DR")="1////"_EXDT_";2////"_XFILL
SET DIC(0)="Z"
FF DO FILE^DICN
KILL DIC("DR"),DIC,DA,LOT,EXDT,DD,DO
End DoDot:2
End DoDot:1
+1 QUIT
TMP SET ^TMP($JOB,"PSXVND",RX)=FLAG_"^"_XFILL_"^"_P515A_"^"_P515B_"^"_HERE_"^"_$SELECT(FLAG=1:RLDT,1:"")
QUIT
MAIL SET XMSUB="CMOP Release Data Acknowledgement"
SET LCNT=1
SET XMDUZ=.5
MM DO XMZ^XMA2
IF XMZ<1
GOTO MM
+1 SET ^XMB(3.9,XMZ,2,LCNT,0)="$$RTN^"_MSNUM_"^"_HERE
SET LCNT=LCNT+1
+2 FOR CC=0:0
SET CC=$ORDER(^TMP($JOB,"PSXREL",CC))
IF CC'>0
QUIT
Begin DoDot:1
+3 SET ^XMB(3.9,XMZ,2,LCNT,0)="$RX^"_$GET(^TMP($JOB,"PSXREL",CC))
SET LCNT=LCNT+1
End DoDot:1
+4 SET ^XMB(3.9,XMZ,2,LCNT,0)="$$INV"
+5 SET CC=""
FOR
SET CC=$ORDER(^TMP($JOB,"PSXVND",CC))
IF CC=""
QUIT
SET RXN=CC
Begin DoDot:1
+6 ;added for PSX*2*36
SET LCNT=LCNT+1
DO NOW^%DTC
SET PSXTM=%
+7 SET ^XMB(3.9,XMZ,2,LCNT,0)="$RXN"_"^"_RXN_"^"_$GET(^TMP($JOB,"PSXVND",CC))_"^"_PSXTM
End DoDot:1
+8 SET ^XMB(3.9,XMZ,2,LCNT+1,0)="$$ENDINV"
+9 SET ^XMB(3.9,XMZ,2,0)="^3.92A^"_LCNT_U_LCNT_U_DT
SET XMDUN="CMOP Manager"
+10 KILL XMY
SET XMY("S.PSXX CMOP SERVER"_DOMAIN)=""
DO ENT1^XMD
+11 ;D ER6^PSXERR Q
+12 IF $DATA(^TMP("PSXCAN1",$JOB))
DO CAN^PSXMSGS
EXIT SET XMSER="S.PSXX CMOP SERVER"
SET XMZ=TXMZ
DO REMSBMSG^XMA1C
EXIT1 KILL XMSUB,XMDUZ,XMDUN,XMY,LCNT,XMZ,CC,PSXREL,CNT,Y,X,RR,LOT,LOT1,EXDT,ALOT
+1 KILL RXN,RX,DLAYGO,FACBAT,FILL,FROM,NDC,P514,REASON,RELDT,STAT,XMREC,XMRG
+2 KILL ^TMP($JOB,"PSXVND"),^TMP($JOB,"PSXREL"),RLDT,FLAG,TXMRG,PSXXMZ,ZSTAT,PSXTM
+3 KILL XQMSG,XQSOP,XX,ZZZ,%,DAT,DOMAIN,PSXJOB,PSXREF,RECD,RXP,TXMZ,XMZ,XMER
+4 KILL XMFROM,XMSER,BAT,PSXREFL,XFILL,FAC,HERE,P515A,P515B,SITE,MSNUM
+5 KILL DIQ,DIV,QTY,PSXUTIL,SHPDT,Z1,PSQUIT
+6 QUIT
+7 ; Return IHS formatted NDC value
FIXNDC(NDC) ; EP
+1 IF $LENGTH(NDC)=11
SET NDC=$EXTRACT(NDC,1,5)_"-"_$EXTRACT(NDC,6,9)_"-"_$EXTRACT(NDC,10,11)
+2 QUIT NDC
