source: WorldVistAEHR/trunk/r/CMOP-PSX/PSXVEND.m@ 1361

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