source: FOIAVistA/tag/r/CMOP-PSX/PSXVEND.m@ 1806

Last change on this file since 1806 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 7.0 KB
Line 
1PSXVEND ;BIR/WPB,HTW,PWC-Send Release Data to the Remote Facility for Filing ;04/08/97 2:06 PM
2 ;;2.0;CMOP;**23,27,35,38**;11 Apr 97
3 ;Reference to ^DIC(4.2 supported by DBIA 1966
4 ;Reference to ^DD(552.41, supported by DBIA 10155
5 ; MODIFIED FOR DOD PILOT
6QUE S ZTRTN="EN^PSXVEND",ZTDESC="CMOP Return of Release Data",ZTIO="PSX",ZTDTH=$H,ZTSAVE("DUZ")="" D ^%ZTLOAD
7 Q
8CLOSE S PTR514=$P(^PSX(552.4,AA,0),U,1)
9 Q:$D(^PSX(552.4,"AR",PTR514))!($D(^PSX(552.4,"AC",SS,AA)))!($D(^PSX(552.4,"AX",SS,AA)))
10 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
11 Q
12TXT I $G(TXT)]"" S LCNT=LCNT+1,^XMB(3.9,XMZ,2,LCNT,0)=TXT K TXT Q
13 ;Called by Taskman to send Release data to Remote
14EN S ZTREQ="@"
15 S ZX=0 F S ZX=$O(^PSX(552.4,"AC",ZX)) Q:ZX'>0 S SITE=ZX D EN1
16 G EXIT1
17 ; DOD MODS NEXT LINE
18EN1 S PSX552=$O(^PSX(552,"D",ZX,"")) I $G(PSX552)>0 S PSXDOD=$P($G(^PSX(552,PSX552,0)),"^",5) D ^PSXDODQY Q ;****DOD
19 S LCNT=0,XMSUB="Vendor release data",XMDUZ=.5
20XMZ D XMZ^XMA2
21 I XMZ'>0 G XMZ
22 D NOW^%DTC
23 S TXT="$$VND^"_%_"^"_XMZ D TXT
24 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
25 .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)
26 .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)
27 .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))_"\"
28 .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)
29 .L +^PSX(552.4,AA,1,BB):600 Q:'$T
30 .S DA=BB,DA(1)=AA,DIE="^PSX(552.4,"_AA_",1,",DR="9////2;15////"_XMZ D ^DIE K DA,DR,DIE
31 .L -^PSX(552.4,AA,1,BB)
32 .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
33 .I $P(LOT,"|",2)'="" S TXT="$LOT^"_$G(LOT) D TXT
34 .K NDC,COMPDT,STAT,REASON,LOT,RXN,FACBAT,CARRIER,PKGID,SHPDT
35 S TXT="$$ENDVND" D TXT
36 S ^XMB(3.9,XMZ,2,0)="^3.92A^"_LCNT_U_LCNT_U_DT,XMDUN="CMOP Manager"
37 ;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
38 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
39 S DOMAIN="@"_$$GET1^DIQ(4.2,FACDOM,.01)
40 K XMY S XMY("S.PSXX CMOP SERVER"_DOMAIN)=""
41 ;K XMY S XMY(DUZ)=""
42 S XMDUZ=.5 D ENT1^XMD
43 D NOW^%DTC
44 S:'$D(^PSX(554,1,3,0)) ^PSX(554,1,3,0)="^554.03DA^^"
45 K DD,DO
46 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
47 Q
48RTN ;called by the server to file the release data acknowledgement in 552.4
49 S FROM=XMFROM,XMSER="S."_XQSOP,TXMZ=XQMSG,ZTREQ="@"
50 K ^TMP($J,"PSXINV")
51 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
52 Q
53UPFL D NOW^%DTC S ACKTM=%
54 S MSGNUM=$P(XMRG,"^",2)
55 S RFAC=$P(XMRG,"^",3)
56DOD ; entry from PSXDODAK to update 554 message
57UPFL1 Q:$G(MSGNUM)=""
58 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,%
59 Q
60FILE Q:$G(XMRG)=""
61 S RXNUM=$P(XMRG,"^",2),PDT=$P(XMRG,"^",3),AA=$P(XMRG,"^",4),BB=$P(XMRG,"^",5),SS=$P(XMRG,"^",7)
62DODRX ; entry point from PSXDODAK to file RX release filed 'ack'
63 S RN=$P($G(^PSX(552.4,AA,1,BB,0)),U,1),RXSTAT=$P(^PSX(552.4,AA,1,BB,0),"^",10)
64 ;I RXSTAT=3 S ^TMP($J,"PSXINV",RXNUM)="" Q
65 Q:'$D(^PSX(552.4,"AX",SS,AA,BB))
66 I $G(MSGNUM)="" S MSGNUM=$P(^PSX(552.4,AA,1,BB,2),"^",3) D UPFL1
67 L +^PSX(552.4,AA,1,BB):600 Q:'$T
68 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
69 L -^PSX(552.4,AA,1,BB)
70 D CLOSE
71 K RXNUM,PDT,AA,BB,SS,RXSTAT,RX
72 Q
73 ;Called by Taskman to file Vendor Release data on DHCP host
74INV S FROM=XMFROM,XMSER="S."_XQSOP,TXMZ=XQMSG
75 F X XMREC G:$G(XMER)<0 EXIT D:$E(XMRG,1,4)["$RXN" FILEINV G:$E(XMRG,1,5)["$$END" END
76 Q
77FILEINV Q:$G(XMRG)=""
78 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)
79DODINV ; entry point from PSXDODAK to file a facility release filed 'nak'
80 S RN=$P($G(^PSX(552.4,AA,1,BB,0)),U,1),RXSTAT=$P(^PSX(552.4,AA,1,BB,0),"^",10)
81 Q:'$D(^PSX(552.4,"AX",SS,AA,BB))
82 S P521=$P(^PSX(552.4,AA,0),"^"),ZBAT=$P(^PSX(552.1,P521,0),"^")
83 S ^TMP("PSXERR",$J,ZBAT,RXN)=STAT_U_FILL_U_""_U_SS_U_AA
84 K P521,ZBAT
85 L +^PSX(552.4,AA,1,BB):600 Q:'$T
86 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
87 L -^PSX(552.4,AA,1,BB)
88 D CLOSE
89 K RXNUM,PDT,AA,BB,SS,RXSTAT,RX
90 Q
91END D NOW^%DTC
92 I $G(XNUM) S DA(1)=1,DA=XNUM,DIE="^PSX(554,"_DA(1)_",3,",DR="1////@;6////"_% D ^DIE K DA,DIE,DR
93EXIT S XMZ=TXMZ D REMSBMSG^XMA1C
94 I $D(^TMP($J,"PSXINV")) D INVREL^PSXMSGS
95 D REMERR
96EXIT1 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
97 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
98 S ZTREQ="@"
99 Q
100 Q
101REMERR ; Builds msg for remote error conditions
102 Q:'$D(^TMP("PSXERR",$J))
103 S XL=" "
104 S XMSUB=RFAC_" CMOP Remote Error Condition Notice",XMDUZ=.5
105 D XMZ^XMA2 Q:XMZ'>0
106 ; ^TMP("PSXERR",$J,TRANS#,RX#)=RX STATUS^FILL #^NOT USED^SITE#^P552.4
107 S ^XMB(3.9,XMZ,2,2,0)=""
108 S ^XMB(3.9,XMZ,2,3,0)=" TRANS # RX # FILL # REMOTE ERROR",XLCT=4
109 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
110 .S ZBAT1=ZBAT_$E(XL,1,(10-$L(ZBAT)))
111 .S XX1=XX_$E(XL,1,(15-$L(XX)))
112 .S DATA=$G(^TMP("PSXERR",$J,ZBAT,XX))
113 .S Y=+$P(DATA,"^"),ERR=$$EXTERNAL^DILFD(552.41,14,"",Y) K Y
114 .S FILL=$P(DATA,"^",2),FILL=FILL_$E(XL,1,(8-$L(FILL)))
115 .N Y S Y=$P(DATA,"^",3) X ^DD("DD") S PDT=Y K Y
116START . ;
117 . ;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
118 .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
119 .S ^XMB(3.9,XMZ,2,XLCT,0)=ZBAT1_XX1_FILL_PDT_ERR,XLCT=XLCT+1
120 .K DATA,P1,P2,ERR,FILL,PDT,PDT1,PDT2,XX1,F2,F3,ZBAT1
121 S ^XMB(3.9,XMZ,2,1,0)="The following prescriptions could not be filed at "_$G(FAC)_" due to listed error conditions."
122 S ^XMB(3.9,XMZ,2,0)="^3.92A^"_XLCT_U_XLCT_U_DT,XMDUN="CMOP Manager"
123 K XMY D GRP^PSXNOTE D ENT1^XMD
124 K FAC,XX,XL,XLCT,ZBAT,RFAC
125 Q
Note: See TracBrowser for help on using the repository browser.