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

PSXVEND.m

Go to the documentation of this file. 
  1. 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
  1.  ;Reference to ^DIC(4.2 supported by DBIA 1966
  1.  ;Reference to ^DD(552.41, supported by DBIA 10155
  1.  ;   MODIFIED FOR DOD PILOT
  1. QUE S ZTRTN="EN^PSXVEND",ZTDESC="CMOP Return of Release Data",ZTIO="PSX",ZTDTH=$H,ZTSAVE("DUZ")="" D ^%ZTLOAD
  1.  Q
  1. CLOSE S PTR514=$P(^PSX(552.4,AA,0),U,1)
  1.  Q:$D(^PSX(552.4,"AR",PTR514))!($D(^PSX(552.4,"AC",SS,AA)))!($D(^PSX(552.4,"AX",SS,AA)))
  1.  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
  1.  Q
  1. TXT I $G(TXT)]"" S LCNT=LCNT+1,^XMB(3.9,XMZ,2,LCNT,0)=TXT K TXT Q
  1.  ;Called by Taskman to send Release data to Remote
  1. EN S ZTREQ="@"
  1.  S ZX=0 F  S ZX=$O(^PSX(552.4,"AC",ZX)) Q:ZX'>0  S SITE=ZX D EN1
  1.  G EXIT1
  1.  ; DOD MODS NEXT LINE
  1. 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
  1.  S LCNT=0,XMSUB="Vendor release data",XMDUZ=.5
  1. XMZ D XMZ^XMA2
  1.  I XMZ'>0 G XMZ
  1.  D NOW^%DTC
  1.  S TXT="$$VND^"_%_"^"_XMZ D TXT
  1.  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
  1.  .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)
  1.  .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)
  1.  .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))_"\"
  1.  .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)
  1.  .L +^PSX(552.4,AA,1,BB):600 Q:'$T
  1.  .S DA=BB,DA(1)=AA,DIE="^PSX(552.4,"_AA_",1,",DR="9////2;15////"_XMZ D ^DIE K DA,DR,DIE
  1.  .L -^PSX(552.4,AA,1,BB)
  1.  .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
  1.  .I $P(LOT,"|",2)'="" S TXT="$LOT^"_$G(LOT) D TXT
  1.  .K NDC,COMPDT,STAT,REASON,LOT,RXN,FACBAT,CARRIER,PKGID,SHPDT
  1.  S TXT="$$ENDVND" D TXT
  1.  S ^XMB(3.9,XMZ,2,0)="^3.92A^"_LCNT_U_LCNT_U_DT,XMDUN="CMOP Manager"
  1.  ;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
  1.  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
  1.  S DOMAIN="@"_$$GET1^DIQ(4.2,FACDOM,.01)
  1.  K XMY S XMY("S.PSXX CMOP SERVER"_DOMAIN)=""
  1.  ;K XMY S XMY(DUZ)=""
  1.  S XMDUZ=.5 D ENT1^XMD
  1.  D NOW^%DTC
  1.  S:'$D(^PSX(554,1,3,0)) ^PSX(554,1,3,0)="^554.03DA^^"
  1.  K DD,DO
  1.  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
  1.  Q
  1. RTN ;called by the server to file the release data acknowledgement in 552.4
  1.  S FROM=XMFROM,XMSER="S."_XQSOP,TXMZ=XQMSG,ZTREQ="@"
  1.  K ^TMP($J,"PSXINV")
  1.  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
  1.  Q
  1. UPFL D NOW^%DTC S ACKTM=%
  1.  S MSGNUM=$P(XMRG,"^",2)
  1.  S RFAC=$P(XMRG,"^",3)
  1. DOD ; entry from PSXDODAK to update 554 message
  1. UPFL1 Q:$G(MSGNUM)=""
  1.  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,%
  1.  Q
  1. FILE Q:$G(XMRG)=""
  1.  S RXNUM=$P(XMRG,"^",2),PDT=$P(XMRG,"^",3),AA=$P(XMRG,"^",4),BB=$P(XMRG,"^",5),SS=$P(XMRG,"^",7)
  1. DODRX ; entry point from PSXDODAK to file RX release filed 'ack'
  1.  S RN=$P($G(^PSX(552.4,AA,1,BB,0)),U,1),RXSTAT=$P(^PSX(552.4,AA,1,BB,0),"^",10)
  1.  ;I RXSTAT=3 S ^TMP($J,"PSXINV",RXNUM)="" Q
  1.  Q:'$D(^PSX(552.4,"AX",SS,AA,BB))
  1.  I $G(MSGNUM)="" S MSGNUM=$P(^PSX(552.4,AA,1,BB,2),"^",3) D UPFL1
  1.  L +^PSX(552.4,AA,1,BB):600 Q:'$T
  1.  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
  1.  L -^PSX(552.4,AA,1,BB)
  1.  D CLOSE
  1.  K RXNUM,PDT,AA,BB,SS,RXSTAT,RX
  1.  Q
  1.  ;Called by Taskman to file Vendor Release data on DHCP host
  1. INV S FROM=XMFROM,XMSER="S."_XQSOP,TXMZ=XQMSG
  1.  F  X XMREC G:$G(XMER)<0 EXIT D:$E(XMRG,1,4)["$RXN" FILEINV G:$E(XMRG,1,5)["$$END" END
  1.  Q
  1. FILEINV Q:$G(XMRG)=""
  1.  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)
  1. DODINV ; entry point from PSXDODAK to file a facility release filed 'nak'
  1.  S RN=$P($G(^PSX(552.4,AA,1,BB,0)),U,1),RXSTAT=$P(^PSX(552.4,AA,1,BB,0),"^",10)
  1.  Q:'$D(^PSX(552.4,"AX",SS,AA,BB))
  1.  S P521=$P(^PSX(552.4,AA,0),"^"),ZBAT=$P(^PSX(552.1,P521,0),"^")
  1.  S ^TMP("PSXERR",$J,ZBAT,RXN)=STAT_U_FILL_U_""_U_SS_U_AA
  1.  K P521,ZBAT
  1.  L +^PSX(552.4,AA,1,BB):600 Q:'$T
  1.  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
  1.  L -^PSX(552.4,AA,1,BB)
  1.  D CLOSE
  1.  K RXNUM,PDT,AA,BB,SS,RXSTAT,RX
  1.  Q
  1. END D NOW^%DTC
  1.  I $G(XNUM) S DA(1)=1,DA=XNUM,DIE="^PSX(554,"_DA(1)_",3,",DR="1////@;6////"_% D ^DIE K DA,DIE,DR
  1. EXIT S XMZ=TXMZ D REMSBMSG^XMA1C
  1.  I $D(^TMP($J,"PSXINV")) D INVREL^PSXMSGS
  1.  D REMERR
  1. 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
  1.  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
  1.  S ZTREQ="@"
  1.  Q
  1.  Q
  1. REMERR ; Builds msg for remote error conditions
  1.  Q:'$D(^TMP("PSXERR",$J))
  1.  S XL="                    "
  1.  S XMSUB=RFAC_" CMOP Remote Error Condition Notice",XMDUZ=.5
  1.  D XMZ^XMA2 Q:XMZ'>0
  1.  ; ^TMP("PSXERR",$J,TRANS#,RX#)=RX STATUS^FILL #^NOT USED^SITE#^P552.4
  1.  S ^XMB(3.9,XMZ,2,2,0)=""
  1.  S ^XMB(3.9,XMZ,2,3,0)=" TRANS #   RX #       FILL #    REMOTE ERROR",XLCT=4
  1.  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
  1.  .S ZBAT1=ZBAT_$E(XL,1,(10-$L(ZBAT)))
  1.  .S XX1=XX_$E(XL,1,(15-$L(XX)))
  1.  .S DATA=$G(^TMP("PSXERR",$J,ZBAT,XX))
  1.  .S Y=+$P(DATA,"^"),ERR=$$EXTERNAL^DILFD(552.41,14,"",Y) K Y
  1.  .S FILL=$P(DATA,"^",2),FILL=FILL_$E(XL,1,(8-$L(FILL)))
  1.  .N Y S Y=$P(DATA,"^",3) X ^DD("DD") S PDT=Y K Y
  1. 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
  1.  .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
  1.  .S ^XMB(3.9,XMZ,2,XLCT,0)=ZBAT1_XX1_FILL_PDT_ERR,XLCT=XLCT+1
  1.  .K DATA,P1,P2,ERR,FILL,PDT,PDT1,PDT2,XX1,F2,F3,ZBAT1
  1.  S ^XMB(3.9,XMZ,2,1,0)="The following prescriptions could not be filed at "_$G(FAC)_" due to listed error conditions."
  1.  S ^XMB(3.9,XMZ,2,0)="^3.92A^"_XLCT_U_XLCT_U_DT,XMDUN="CMOP Manager"
  1.  K XMY D GRP^PSXNOTE D ENT1^XMD
  1.  K FAC,XX,XL,XLCT,ZBAT,RFAC
  1.  Q