- 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
