PSXVEND ;BIR/WPB,HTW,PWC-Send Release Data to the Remote Facility for Filing ;04/08/97 2:06 PM
;;2.0;CMOP;**23,27,35,38**;11 Apr 97
;Reference to ^DIC(4.2 supported by DBIA 1966
;Reference to ^DD(552.41, supported by DBIA 10155
; MODIFIED FOR DOD PILOT
QUE S ZTRTN="EN^PSXVEND",ZTDESC="CMOP Return of Release Data",ZTIO="PSX",ZTDTH=$H,ZTSAVE("DUZ")="" D ^%ZTLOAD
Q
CLOSE S PTR514=$P(^PSX(552.4,AA,0),U,1)
Q:$D(^PSX(552.4,"AR",PTR514))!($D(^PSX(552.4,"AC",SS,AA)))!($D(^PSX(552.4,"AX",SS,AA)))
S $P(^PSX(552.1,PTR514,0),"^",2)=4,DA=PTR514,DIE="^PSX(552.1,",DR="7///"_PDT_";19////1" D ^DIE K DA,DIE,DR S DA=PTR514,DIK="^PSX(552.1," D IX^DIK K DIK
Q
TXT I $G(TXT)]"" S LCNT=LCNT+1,^XMB(3.9,XMZ,2,LCNT,0)=TXT K TXT Q
;Called by Taskman to send Release data to Remote
EN S ZTREQ="@"
S ZX=0 F S ZX=$O(^PSX(552.4,"AC",ZX)) Q:ZX'>0 S SITE=ZX D EN1
G EXIT1
; DOD MODS NEXT LINE
EN1 S PSX552=$O(^PSX(552,"D",ZX,"")) I $G(PSX552)>0 S PSXDOD=$P($G(^PSX(552,PSX552,0)),"^",5) D ^PSXDODQY Q ;****DOD
S LCNT=0,XMSUB="Vendor release data",XMDUZ=.5
XMZ D XMZ^XMA2
I XMZ'>0 G XMZ
D NOW^%DTC
S TXT="$$VND^"_%_"^"_XMZ D TXT
F AA=0:0 S AA=$O(^PSX(552.4,"AC",ZX,AA)) Q:AA'>0 S BB=0 F S BB=$O(^PSX(552.4,"AC",ZX,AA,BB)) Q:BB'>0 D
.S FACBAT=$P(^PSX(552.1,+$P(^PSX(552.4,AA,0),"^"),0),"^"),RXN=$P($G(^PSX(552.4,AA,1,BB,0)),U,1),FAC=$P(FACBAT,"-",1),DRG=$P(^PSX(552.4,AA,1,BB,0),"^",4),QTY=$P(^PSX(552.4,AA,1,BB,0),"^",13)
.S NDC=$P($G(^PSX(552.4,AA,1,BB,0)),U,5),COMPDT=$P($G(^(0)),U,9),STAT=$P($G(^(0)),U,2),FILL=$P($G(^(0)),U,12) S:STAT=2 REASON=$P($G(^(0)),U,3)
.S LOT="|" F CC=0:0 S CC=$O(^PSX(552.4,AA,1,BB,1,CC)) Q:CC'>0 S LOT=LOT_$G(^PSX(552.4,AA,1,BB,1,CC,0))_"\"
.S SHPDT=$P($G(^PSX(552.4,AA,1,BB,2)),"^",4),CARRIER=$P($G(^PSX(552.4,AA,1,BB,2)),"^",5),PKGID=$P($G(^(2)),"^",6)
.L +^PSX(552.4,AA,1,BB):600 Q:'$T
.S DA=BB,DA(1)=AA,DIE="^PSX(552.4,"_AA_",1,",DR="9////2;15////"_XMZ D ^DIE K DA,DR,DIE
.L -^PSX(552.4,AA,1,BB)
.S TXT="$RX^"_RXN_U_FACBAT_U_$G(NDC)_U_COMPDT_U_STAT_U_FILL_U_$G(REASON)_U_AA_U_BB_U_$G(QTY)_U_$G(DRG)_U_CARRIER_U_PKGID_U_$G(SHPDT),TRX=$G(TRX)+1 D TXT
.I $P(LOT,"|",2)'="" S TXT="$LOT^"_$G(LOT) D TXT
.K NDC,COMPDT,STAT,REASON,LOT,RXN,FACBAT,CARRIER,PKGID,SHPDT
S TXT="$$ENDVND" D TXT
S ^XMB(3.9,XMZ,2,0)="^3.92A^"_LCNT_U_LCNT_U_DT,XMDUN="CMOP Manager"
;S X=SITE,DIC="4",DIC(0)="XMZO" S:$D(PSX(552,"D",X)) X=$E(X,2,99) D ^DIC S PTR=+Y,XPTR=$O(^PSX(552,"B",PTR,"")),FACDOM=$P($G(^PSX(552,XPTR,0)),U,4) ;****DOD L1
S X=SITE,AGNCY="VASTANUM" S:$D(PSX(552,"D",X)) X=$E(X,2,99),AGNCY="DMIS" S PTR=$$IEN^XUMF(4,AGNCY,X),XPTR=$O(^PSX(552,"B",PTR,"")),FACDOM=$P($G(^PSX(552,XPTR,0)),U,4) ;****DOD L1
S DOMAIN="@"_$$GET1^DIQ(4.2,FACDOM,.01)
K XMY S XMY("S.PSXX CMOP SERVER"_DOMAIN)=""
;K XMY S XMY(DUZ)=""
S XMDUZ=.5 D ENT1^XMD
D NOW^%DTC
S:'$D(^PSX(554,1,3,0)) ^PSX(554,1,3,0)="^554.03DA^^"
K DD,DO
S DA(1)=1,DIC="^PSX(554,"_DA(1)_",3,",DIC(0)="Z",DIC("DR")="1////"_XMZ_";2////"_FAC_";5////"_TRX,X=% D FILE^DICN K DIC,DA,DIC("DR"),DIC(0),X,TRX
Q
RTN ;called by the server to file the release data acknowledgement in 552.4
S FROM=XMFROM,XMSER="S."_XQSOP,TXMZ=XQMSG,ZTREQ="@"
K ^TMP($J,"PSXINV")
F X XMREC G:$G(XMER)<0 EXIT D:$E(XMRG,1,5)["$$RTN" UPFL D:$E(XMRG,1,3)["$RX" FILE G:$E(XMRG,1,5)["$$INV" INV G:$E(XMRG,1,5)["$$END" END
Q
UPFL D NOW^%DTC S ACKTM=%
S MSGNUM=$P(XMRG,"^",2)
S RFAC=$P(XMRG,"^",3)
DOD ; entry from PSXDODAK to update 554 message
UPFL1 Q:$G(MSGNUM)=""
Q:'$D(^PSX(554,"AC",MSGNUM)) S (XNUM,RNUM)=$O(^PSX(554,"AC",MSGNUM,"")),DA(1)=1,DA=RNUM,DIE="^PSX(554,"_DA(1)_",3,",DR="3////"_TXMZ_";4////"_ACKTM D ^DIE K DA,DR,DIE,%
Q
FILE Q:$G(XMRG)=""
S RXNUM=$P(XMRG,"^",2),PDT=$P(XMRG,"^",3),AA=$P(XMRG,"^",4),BB=$P(XMRG,"^",5),SS=$P(XMRG,"^",7)
DODRX ; entry point from PSXDODAK to file RX release filed 'ack'
S RN=$P($G(^PSX(552.4,AA,1,BB,0)),U,1),RXSTAT=$P(^PSX(552.4,AA,1,BB,0),"^",10)
;I RXSTAT=3 S ^TMP($J,"PSXINV",RXNUM)="" Q
Q:'$D(^PSX(552.4,"AX",SS,AA,BB))
I $G(MSGNUM)="" S MSGNUM=$P(^PSX(552.4,AA,1,BB,2),"^",3) D UPFL1
L +^PSX(552.4,AA,1,BB):600 Q:'$T
I RN=RXNUM S DA(1)=AA,DA=BB,DIE="^PSX(552.4,"_AA_",1,",DR="7///"_PDT_";9////3;15////@" D ^DIE K DIE,DA,DR
L -^PSX(552.4,AA,1,BB)
D CLOSE
K RXNUM,PDT,AA,BB,SS,RXSTAT,RX
Q
;Called by Taskman to file Vendor Release data on DHCP host
INV S FROM=XMFROM,XMSER="S."_XQSOP,TXMZ=XQMSG
F X XMREC G:$G(XMER)<0 EXIT D:$E(XMRG,1,4)["$RXN" FILEINV G:$E(XMRG,1,5)["$$END" END
Q
FILEINV Q:$G(XMRG)=""
S RXN=$P(XMRG,"^",2),STAT=$P(XMRG,"^",3),FILL=$P(XMRG,"^",4),PDT=$P(XMRG,"^",8),AA=$P(XMRG,"^",5),BB=$P(XMRG,"^",6),SS=$P(XMRG,"^",7)
DODINV ; entry point from PSXDODAK to file a facility release filed 'nak'
S RN=$P($G(^PSX(552.4,AA,1,BB,0)),U,1),RXSTAT=$P(^PSX(552.4,AA,1,BB,0),"^",10)
Q:'$D(^PSX(552.4,"AX",SS,AA,BB))
S P521=$P(^PSX(552.4,AA,0),"^"),ZBAT=$P(^PSX(552.1,P521,0),"^")
S ^TMP("PSXERR",$J,ZBAT,RXN)=STAT_U_FILL_U_""_U_SS_U_AA
K P521,ZBAT
L +^PSX(552.4,AA,1,BB):600 Q:'$T
I RN=RXN S DA(1)=AA,DA=BB,DIE="^PSX(552.4,"_AA_",1,",DR="9////4;7///"_PDT_";14////"_STAT_";15////@" D ^DIE K DIE,DA,DR
L -^PSX(552.4,AA,1,BB)
D CLOSE
K RXNUM,PDT,AA,BB,SS,RXSTAT,RX
Q
END D NOW^%DTC
I $G(XNUM) S DA(1)=1,DA=XNUM,DIE="^PSX(554,"_DA(1)_",3,",DR="1////@;6////"_% D ^DIE K DA,DIE,DR
EXIT S XMZ=TXMZ D REMSBMSG^XMA1C
I $D(^TMP($J,"PSXINV")) D INVREL^PSXMSGS
D REMERR
EXIT1 K XMER,XMRG,XMZ,PDT,RXNUM,%,FROM,LCNT,XMDUN,XMDUZ,XMFROM,XMREC,XMSUB,XMY,NDC,COMPDT,STAT,REASON,LOT,RXN,FACBAT,AA,BB,CC,ZZ,XX,YY,TXT,CNT,DOMAIN,RN,SS,ZX
K FACDOM,FILL,PTR,SITE,TXMZ,XMSER,XPTR,XQMSG,XQSOP,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK,FAC,MSGNUM,PRT514,XNUM,PTR514,ACKTM,QTY,RNUM,DRG,RFAC
S ZTREQ="@"
Q
Q
REMERR ; Builds msg for remote error conditions
Q:'$D(^TMP("PSXERR",$J))
S XL=" "
S XMSUB=RFAC_" CMOP Remote Error Condition Notice",XMDUZ=.5
D XMZ^XMA2 Q:XMZ'>0
; ^TMP("PSXERR",$J,TRANS#,RX#)=RX STATUS^FILL #^NOT USED^SITE#^P552.4
S ^XMB(3.9,XMZ,2,2,0)=""
S ^XMB(3.9,XMZ,2,3,0)=" TRANS # RX # FILL # REMOTE ERROR",XLCT=4
S ZBAT="" F S ZBAT=$O(^TMP("PSXERR",$J,ZBAT)) Q:$G(ZBAT)']"" S XX="" F S XX=$O(^TMP("PSXERR",$J,ZBAT,XX)) Q:$G(XX)']"" D
.S ZBAT1=ZBAT_$E(XL,1,(10-$L(ZBAT)))
.S XX1=XX_$E(XL,1,(15-$L(XX)))
.S DATA=$G(^TMP("PSXERR",$J,ZBAT,XX))
.S Y=+$P(DATA,"^"),ERR=$$EXTERNAL^DILFD(552.41,14,"",Y) K Y
.S FILL=$P(DATA,"^",2),FILL=FILL_$E(XL,1,(8-$L(FILL)))
.N Y S Y=$P(DATA,"^",3) X ^DD("DD") S PDT=Y K Y
START . ;
. ;I '$D(FAC) S F2=+$P(^PSX(552.1,+$P(^PSX(552.4,$P(DATA,"^",5),0),"^"),0),"^"),X=F2,DIC="4",DIC(0)="XZMO" S:$D(^PSX(552,"D",X)) X=$E(X,2,99) D ^DIC S F3=+Y,FAC=$P(Y,"^",2) K DIC,X,Y ;****DOD L1
.I '$D(FAC) S F2=+$P(^PSX(552.1,+$P(^PSX(552.4,$P(DATA,"^",5),0),"^"),0),"^"),X=F2,AGNCY="VASTANUM" S:$D(^PSX(552,"D",X)) X=$E(X,2,99),AGNCY="DMIS" S F3=$$IEN^XUMF(4,AGNCY,X),FAC=$$NAME^XUAF4(F3) K AGNCY,X,Y ;****DOD L1
.S ^XMB(3.9,XMZ,2,XLCT,0)=ZBAT1_XX1_FILL_PDT_ERR,XLCT=XLCT+1
.K DATA,P1,P2,ERR,FILL,PDT,PDT1,PDT2,XX1,F2,F3,ZBAT1
S ^XMB(3.9,XMZ,2,1,0)="The following prescriptions could not be filed at "_$G(FAC)_" due to listed error conditions."
S ^XMB(3.9,XMZ,2,0)="^3.92A^"_XLCT_U_XLCT_U_DT,XMDUN="CMOP Manager"
K XMY D GRP^PSXNOTE D ENT1^XMD
K FAC,XX,XL,XLCT,ZBAT,RFAC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXVEND 7312 printed Dec 13, 2024@01:45:26 Page 2
PSXVEND ;BIR/WPB,HTW,PWC-Send Release Data to the Remote Facility for Filing ;04/08/97 2:06 PM
+1 ;;2.0;CMOP;**23,27,35,38**;11 Apr 97
+2 ;Reference to ^DIC(4.2 supported by DBIA 1966
+3 ;Reference to ^DD(552.41, supported by DBIA 10155
+4 ; MODIFIED FOR DOD PILOT
QUE SET ZTRTN="EN^PSXVEND"
SET ZTDESC="CMOP Return of Release Data"
SET ZTIO="PSX"
SET ZTDTH=$HOROLOG
SET ZTSAVE("DUZ")=""
DO ^%ZTLOAD
+1 QUIT
CLOSE SET PTR514=$PIECE(^PSX(552.4,AA,0),U,1)
+1 if $DATA(^PSX(552.4,"AR",PTR514))!($DATA(^PSX(552.4,"AC",SS,AA)))!($DATA(^PSX(552.4,"AX",SS,AA)))
QUIT
+2 SET $PIECE(^PSX(552.1,PTR514,0),"^",2)=4
SET DA=PTR514
SET DIE="^PSX(552.1,"
SET DR="7///"_PDT_";19////1"
DO ^DIE
KILL DA,DIE,DR
SET DA=PTR514
SET DIK="^PSX(552.1,"
DO IX^DIK
KILL DIK
+3 QUIT
TXT IF $GET(TXT)]""
SET LCNT=LCNT+1
SET ^XMB(3.9,XMZ,2,LCNT,0)=TXT
KILL TXT
QUIT
+1 ;Called by Taskman to send Release data to Remote
EN SET ZTREQ="@"
+1 SET ZX=0
FOR
SET ZX=$ORDER(^PSX(552.4,"AC",ZX))
if ZX'>0
QUIT
SET SITE=ZX
DO EN1
+2 GOTO EXIT1
+3 ; DOD MODS NEXT LINE
EN1 ;****DOD
SET PSX552=$ORDER(^PSX(552,"D",ZX,""))
IF $GET(PSX552)>0
SET PSXDOD=$PIECE($GET(^PSX(552,PSX552,0)),"^",5)
DO ^PSXDODQY
QUIT
+1 SET LCNT=0
SET XMSUB="Vendor release data"
SET XMDUZ=.5
XMZ DO XMZ^XMA2
+1 IF XMZ'>0
GOTO XMZ
+2 DO NOW^%DTC
+3 SET TXT="$$VND^"_%_"^"_XMZ
DO TXT
+4 FOR AA=0:0
SET AA=$ORDER(^PSX(552.4,"AC",ZX,AA))
if AA'>0
QUIT
SET BB=0
FOR
SET BB=$ORDER(^PSX(552.4,"AC",ZX,AA,BB))
if BB'>0
QUIT
Begin DoDot:1
+5 SET FACBAT=$PIECE(^PSX(552.1,+$PIECE(^PSX(552.4,AA,0),"^"),0),"^")
SET RXN=$PIECE($GET(^PSX(552.4,AA,1,BB,0)),U,1)
SET FAC=$PIECE(FACBAT,"-",1)
SET DRG=$PIECE(^PSX(552.4,AA,1,BB,0),"^",4)
SET QTY=$PIECE(^PSX(552.4,AA,1,BB,0),"^",13)
+6 SET NDC=$PIECE($GET(^PSX(552.4,AA,1,BB,0)),U,5)
SET COMPDT=$PIECE($GET(^(0)),U,9)
SET STAT=$PIECE($GET(^(0)),U,2)
SET FILL=$PIECE($GET(^(0)),U,12)
if STAT=2
SET REASON=$PIECE($GET(^(0)),U,3)
+7 SET LOT="|"
FOR CC=0:0
SET CC=$ORDER(^PSX(552.4,AA,1,BB,1,CC))
if CC'>0
QUIT
SET LOT=LOT_$GET(^PSX(552.4,AA,1,BB,1,CC,0))_"\"
+8 SET SHPDT=$PIECE($GET(^PSX(552.4,AA,1,BB,2)),"^",4)
SET CARRIER=$PIECE($GET(^PSX(552.4,AA,1,BB,2)),"^",5)
SET PKGID=$PIECE($GET(^(2)),"^",6)
+9 LOCK +^PSX(552.4,AA,1,BB):600
if '$TEST
QUIT
+10 SET DA=BB
SET DA(1)=AA
SET DIE="^PSX(552.4,"_AA_",1,"
SET DR="9////2;15////"_XMZ
DO ^DIE
KILL DA,DR,DIE
+11 LOCK -^PSX(552.4,AA,1,BB)
+12 SET TXT="$RX^"_RXN_U_FACBAT_U_$GET(NDC)_U_COMPDT_U_STAT_U_FILL_U_$GET(REASON)_U_AA_U_BB_U_$GET(QTY)_U_$GET(DRG)_U_CARRIER_U_PKGID_U_$GET(SHPDT)
SET TRX=$GET(TRX)+1
DO TXT
+13 IF $PIECE(LOT,"|",2)'=""
SET TXT="$LOT^"_$GET(LOT)
DO TXT
+14 KILL NDC,COMPDT,STAT,REASON,LOT,RXN,FACBAT,CARRIER,PKGID,SHPDT
End DoDot:1
+15 SET TXT="$$ENDVND"
DO TXT
+16 SET ^XMB(3.9,XMZ,2,0)="^3.92A^"_LCNT_U_LCNT_U_DT
SET XMDUN="CMOP Manager"
+17 ;S X=SITE,DIC="4",DIC(0)="XMZO" S:$D(PSX(552,"D",X)) X=$E(X,2,99) D ^DIC S PTR=+Y,XPTR=$O(^PSX(552,"B",PTR,"")),FACDOM=$P($G(^PSX(552,XPTR,0)),U,4) ;****DOD L1
+18 ;****DOD L1
SET X=SITE
SET AGNCY="VASTANUM"
if $DATA(PSX(552,"D",X))
SET X=$EXTRACT(X,2,99)
SET AGNCY="DMIS"
SET PTR=$$IEN^XUMF(4,AGNCY,X)
SET XPTR=$ORDER(^PSX(552,"B",PTR,""))
SET FACDOM=$PIECE($GET(^PSX(552,XPTR,0)),U,4)
+19 SET DOMAIN="@"_$$GET1^DIQ(4.2,FACDOM,.01)
+20 KILL XMY
SET XMY("S.PSXX CMOP SERVER"_DOMAIN)=""
+21 ;K XMY S XMY(DUZ)=""
+22 SET XMDUZ=.5
DO ENT1^XMD
+23 DO NOW^%DTC
+24 if '$DATA(^PSX(554,1,3,0))
SET ^PSX(554,1,3,0)="^554.03DA^^"
+25 KILL DD,DO
+26 SET DA(1)=1
SET DIC="^PSX(554,"_DA(1)_",3,"
SET DIC(0)="Z"
SET DIC("DR")="1////"_XMZ_";2////"_FAC_";5////"_TRX
SET X=%
DO FILE^DICN
KILL DIC,DA,DIC("DR"),DIC(0),X,TRX
+27 QUIT
RTN ;called by the server to file the release data acknowledgement in 552.4
+1 SET FROM=XMFROM
SET XMSER="S."_XQSOP
SET TXMZ=XQMSG
SET ZTREQ="@"
+2 KILL ^TMP($JOB,"PSXINV")
+3 FOR
XECUTE XMREC
if $GET(XMER)<0
GOTO EXIT
if $EXTRACT(XMRG,1,5)["$$RTN"
DO UPFL
if $EXTRACT(XMRG,1,3)["$RX"
DO FILE
if $EXTRACT(XMRG,1,5)["$$INV"
GOTO INV
if $EXTRACT(XMRG,1,5)["$$END"
GOTO END
+4 QUIT
UPFL DO NOW^%DTC
SET ACKTM=%
+1 SET MSGNUM=$PIECE(XMRG,"^",2)
+2 SET RFAC=$PIECE(XMRG,"^",3)
DOD ; entry from PSXDODAK to update 554 message
UPFL1 if $GET(MSGNUM)=""
QUIT
+1 if '$DATA(^PSX(554,"AC",MSGNUM))
QUIT
SET (XNUM,RNUM)=$ORDER(^PSX(554,"AC",MSGNUM,""))
SET DA(1)=1
SET DA=RNUM
SET DIE="^PSX(554,"_DA(1)_",3,"
SET DR="3////"_TXMZ_";4////"_ACKTM
DO ^DIE
KILL DA,DR,DIE,%
+2 QUIT
FILE if $GET(XMRG)=""
QUIT
+1 SET RXNUM=$PIECE(XMRG,"^",2)
SET PDT=$PIECE(XMRG,"^",3)
SET AA=$PIECE(XMRG,"^",4)
SET BB=$PIECE(XMRG,"^",5)
SET SS=$PIECE(XMRG,"^",7)
DODRX ; entry point from PSXDODAK to file RX release filed 'ack'
+1 SET RN=$PIECE($GET(^PSX(552.4,AA,1,BB,0)),U,1)
SET RXSTAT=$PIECE(^PSX(552.4,AA,1,BB,0),"^",10)
+2 ;I RXSTAT=3 S ^TMP($J,"PSXINV",RXNUM)="" Q
+3 if '$DATA(^PSX(552.4,"AX",SS,AA,BB))
QUIT
+4 IF $GET(MSGNUM)=""
SET MSGNUM=$PIECE(^PSX(552.4,AA,1,BB,2),"^",3)
DO UPFL1
+5 LOCK +^PSX(552.4,AA,1,BB):600
if '$TEST
QUIT
+6 IF RN=RXNUM
SET DA(1)=AA
SET DA=BB
SET DIE="^PSX(552.4,"_AA_",1,"
SET DR="7///"_PDT_";9////3;15////@"
DO ^DIE
KILL DIE,DA,DR
+7 LOCK -^PSX(552.4,AA,1,BB)
+8 DO CLOSE
+9 KILL RXNUM,PDT,AA,BB,SS,RXSTAT,RX
+10 QUIT
+11 ;Called by Taskman to file Vendor Release data on DHCP host
INV SET FROM=XMFROM
SET XMSER="S."_XQSOP
SET TXMZ=XQMSG
+1 FOR
XECUTE XMREC
if $GET(XMER)<0
GOTO EXIT
if $EXTRACT(XMRG,1,4)["$RXN"
DO FILEINV
if $EXTRACT(XMRG,1,5)["$$END"
GOTO END
+2 QUIT
FILEINV if $GET(XMRG)=""
QUIT
+1 SET RXN=$PIECE(XMRG,"^",2)
SET STAT=$PIECE(XMRG,"^",3)
SET FILL=$PIECE(XMRG,"^",4)
SET PDT=$PIECE(XMRG,"^",8)
SET AA=$PIECE(XMRG,"^",5)
SET BB=$PIECE(XMRG,"^",6)
SET SS=$PIECE(XMRG,"^",7)
DODINV ; entry point from PSXDODAK to file a facility release filed 'nak'
+1 SET RN=$PIECE($GET(^PSX(552.4,AA,1,BB,0)),U,1)
SET RXSTAT=$PIECE(^PSX(552.4,AA,1,BB,0),"^",10)
+2 if '$DATA(^PSX(552.4,"AX",SS,AA,BB))
QUIT
+3 SET P521=$PIECE(^PSX(552.4,AA,0),"^")
SET ZBAT=$PIECE(^PSX(552.1,P521,0),"^")
+4 SET ^TMP("PSXERR",$JOB,ZBAT,RXN)=STAT_U_FILL_U_""_U_SS_U_AA
+5 KILL P521,ZBAT
+6 LOCK +^PSX(552.4,AA,1,BB):600
if '$TEST
QUIT
+7 IF RN=RXN
SET DA(1)=AA
SET DA=BB
SET DIE="^PSX(552.4,"_AA_",1,"
SET DR="9////4;7///"_PDT_";14////"_STAT_";15////@"
DO ^DIE
KILL DIE,DA,DR
+8 LOCK -^PSX(552.4,AA,1,BB)
+9 DO CLOSE
+10 KILL RXNUM,PDT,AA,BB,SS,RXSTAT,RX
+11 QUIT
END DO NOW^%DTC
+1 IF $GET(XNUM)
SET DA(1)=1
SET DA=XNUM
SET DIE="^PSX(554,"_DA(1)_",3,"
SET DR="1////@;6////"_%
DO ^DIE
KILL DA,DIE,DR
EXIT SET XMZ=TXMZ
DO REMSBMSG^XMA1C
+1 IF $DATA(^TMP($JOB,"PSXINV"))
DO INVREL^PSXMSGS
+2 DO REMERR
EXIT1 KILL XMER,XMRG,XMZ,PDT,RXNUM,%,FROM,LCNT,XMDUN,XMDUZ,XMFROM,XMREC,XMSUB,XMY,NDC,COMPDT,STAT,REASON,LOT,RXN,FACBAT,AA,BB,CC,ZZ,XX,YY,TXT,CNT,DOMAIN,RN,SS,ZX
+1 KILL FACDOM,FILL,PTR,SITE,TXMZ,XMSER,XPTR,XQMSG,XQSOP,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK,FAC,MSGNUM,PRT514,XNUM,PTR514,ACKTM,QTY,RNUM,DRG,RFAC
+2 SET ZTREQ="@"
+3 QUIT
+4 QUIT
REMERR ; Builds msg for remote error conditions
+1 if '$DATA(^TMP("PSXERR",$JOB))
QUIT
+2 SET XL=" "
+3 SET XMSUB=RFAC_" CMOP Remote Error Condition Notice"
SET XMDUZ=.5
+4 DO XMZ^XMA2
if XMZ'>0
QUIT
+5 ; ^TMP("PSXERR",$J,TRANS#,RX#)=RX STATUS^FILL #^NOT USED^SITE#^P552.4
+6 SET ^XMB(3.9,XMZ,2,2,0)=""
+7 SET ^XMB(3.9,XMZ,2,3,0)=" TRANS # RX # FILL # REMOTE ERROR"
SET XLCT=4
+8 SET ZBAT=""
FOR
SET ZBAT=$ORDER(^TMP("PSXERR",$JOB,ZBAT))
if $GET(ZBAT)']""
QUIT
SET XX=""
FOR
SET XX=$ORDER(^TMP("PSXERR",$JOB,ZBAT,XX))
if $GET(XX)']""
QUIT
Begin DoDot:1
+9 SET ZBAT1=ZBAT_$EXTRACT(XL,1,(10-$LENGTH(ZBAT)))
+10 SET XX1=XX_$EXTRACT(XL,1,(15-$LENGTH(XX)))
+11 SET DATA=$GET(^TMP("PSXERR",$JOB,ZBAT,XX))
+12 SET Y=+$PIECE(DATA,"^")
SET ERR=$$EXTERNAL^DILFD(552.41,14,"",Y)
KILL Y
+13 SET FILL=$PIECE(DATA,"^",2)
SET FILL=FILL_$EXTRACT(XL,1,(8-$LENGTH(FILL)))
+14 NEW Y
SET Y=$PIECE(DATA,"^",3)
XECUTE ^DD("DD")
SET PDT=Y
KILL Y
START ;
+1 ;I '$D(FAC) S F2=+$P(^PSX(552.1,+$P(^PSX(552.4,$P(DATA,"^",5),0),"^"),0),"^"),X=F2,DIC="4",DIC(0)="XZMO" S:$D(^PSX(552,"D",X)) X=$E(X,2,99) D ^DIC S F3=+Y,FAC=$P(Y,"^",2) K DIC,X,Y ;****DOD L1
+2 ;****DOD L1
IF '$DATA(FAC)
SET F2=+$PIECE(^PSX(552.1,+$PIECE(^PSX(552.4,$PIECE(DATA,"^",5),0),"^"),0),"^")
SET X=F2
SET AGNCY="VASTANUM"
if $DATA(^PSX(552,"D",X))
SET X=$EXTRACT(X,2,99)
SET AGNCY="DMIS"
SET F3=$$IEN^XUMF(4,AGNCY,X)
SET FAC=$$NAME^XUAF4(F3)
KILL AGNCY,X,Y
+3 SET ^XMB(3.9,XMZ,2,XLCT,0)=ZBAT1_XX1_FILL_PDT_ERR
SET XLCT=XLCT+1
+4 KILL DATA,P1,P2,ERR,FILL,PDT,PDT1,PDT2,XX1,F2,F3,ZBAT1
End DoDot:1
+5 SET ^XMB(3.9,XMZ,2,1,0)="The following prescriptions could not be filed at "_$GET(FAC)_" due to listed error conditions."
+6 SET ^XMB(3.9,XMZ,2,0)="^3.92A^"_XLCT_U_XLCT_U_DT
SET XMDUN="CMOP Manager"
+7 KILL XMY
DO GRP^PSXNOTE
DO ENT1^XMD
+8 KILL FAC,XX,XL,XLCT,ZBAT,RFAC
+9 QUIT
