source: FOIAVistA/tag/r/CMOP-PSX/PSXDODAK.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 3.3 KB
Line 
1PSXDODAK ;BIR/PDW-FILE .QACs FACILITY RELEASE PROCESSED ACKs & NAKs ;09/09/02 10:45 AM
2 ;;2.0;CMOP;**38,45**;11 Apr 97
3EN(PATH,FNAME) ; needs directory & file name
4 ; force an error in the next line
5 ;S X=ERROR ; generate an undefined error
6 D EXIT
7 I $L(PATH),$L(FNAME) I 1
8 E S PSXERR="0^BAD PATH OR FILENAME" G ERRMSG
9 K ^TMP($J,"PSXDOD")
10 S GBL="^TMP("_$J_",""PSXDOD"",1)"
11 S Y=$$FTG^%ZISH(PATH,FNAME,GBL,3)
12 I Y'>0 S PSXERR="9^"_PATH_U_FNAME_U_" DID NOT LOAD" G ERRMSG
13 I $D(^TMP($J,"PSXDOD"))'>1 S PSXERR="9^"_PATH_U_FNAME_U_" DID NOT LOAD" G ERRMSG
14 S FHS=^TMP($J,"PSXDOD",1),BHS=^TMP($J,"PSXDOD",2)
15 I $E(FHS,1,3)="FHS",$E(BHS,1,3)="BHS" I 1
16 E S PSXERR="1^File headers not correct ^"_FNAME Q
17 ; setup variables to call into PSXVEND for filing acks and nacks
18 ;BHS|^~\&|CHCS|VistA|20020417081343||||0617-021081441
19 F YY="PDT^5","MSG^9" D PIECE(BHS,"|",YY)
20 S (PSXPDT,PDT)=$$FMDATE^HLFNC(PDT),TXMZ="1"_MSG
21 ;MSGNUM is to be the same ID of the release message .qry the .qac is responding to
22 S SS="1"_$P(MSG,"-"),MSGNUM=$P(MSG,"-",2)
23 D NOW^%DTC S ACKTM=%
24 I $E(IOST)="C" W !,"UPDATING ",MSGNUM
25 D DOD^PSXVEND ; update 554 message status
26 ;
27 F LNNUM=3:1 S LN=$G(^TMP($J,"PSXDOD",LNNUM)) Q:LN="" S SEG=$E(LN,1,3) Q:SEG="BTS" D:SEG="MSA" MSA
28 ;
29EXIT ;
30 K ^TMP($J,"PSXDOD")
31 K FHS,BHS,PDT,MSG,TXMZ,MSGNUM,HOLD
32 Q
33MSA ; pull variables from MSA segment and call into PSXVEND $RX or $INV
34 ;MSA|CA|0617-AA116-2|
35 ;MSA|CR|516-11450-8954|2-RX ENTRY MISSING
36 I $E(IOST)="C" W !,LN
37 F YY="TYP^2","RXNDX^3","STAT^4" D PIECE(LN,"|",YY)
38 S RXNDX="1"_RXNDX,(RXN,RXNUM)=$P(RXNDX,"-",2),FILL=$P(RXNDX,"-",3),STAT=+STAT
39 I '$D(^PSX(552.4,"E",RXNDX)) S PSXERR=".QAC RX Not Found "_RXNDX_" "_FNAME D ERRMSG Q
40 S AA=$O(^PSX(552.4,"E",RXNDX,0)),BB=$O(^PSX(552.4,"E",RXNDX,AA,0))
41 I $E(IOST)="C" W !,"ENTRY AA BB ",AA," ",BB
42 I AA,BB I 1
43 E S PSXERR="QAC RX Entry Not Found "_RXNDX_" "_FNAME D ERRMSG Q
44 S SS="1"_$P(MSG,"-"),PDT=PSXPDT
45 K DIC,DA,DR,DIE,DO,DD
46 D:TYP="CA" DODRX^PSXVEND
47 D:TYP="CR" DODINV^PSXVEND
48 Q
49PIECE(REC,DLM,XX) ;
50 ; Set variable V = piece P of REC using delimiter DLM
51 N V,P S V=$P(XX,U),P=$P(XX,U,2),@V=$P(REC,DLM,P)
52 Q
53PUT(REC,DLM,XX) ;
54 ; Set Variable V into piece P of REC using delimiter DLM
55 N V,P S V=$P(XX,U),P=$P(XX,U,2)
56 S $P(REC,DLM,P)=$G(@V)
57 Q
58ERRMSG ;send error message to folks & DOD
59 S DIRHOLD=$$GET1^DIQ(554,1,23),HOLD=$G(HOLD)+1
60 I HOLD=1 D
61 . F XX=1:1:5 S Y=$$GTF^%ZISH($NA(^TMP($J,"PSXDOD",1)),3,DIRHOLD,FNAME) Q:Y=1 H 4
62 . I Y'=1 S GBL=$NA(^TMP($J,"PSXDOD")) D FALERT^PSXDODNT(FNAME,DIRHOLD,GBL)
63 S XMSUB="DOD CMOP Error "_FNAME
64 ;S XMY(DUZ)="" ;***TESTING
65 S XMY("G.PSXX CMOP MANAGERS")=""
66 S XMTEXT="PSXTXT("
67 S PSXTXT(1,0)="DOD CMOP .QAC Facility Release Acknowledgement filing experienced an error"
68 S PSXTXT(2,0)=$G(PSXERR)
69 S PSXTXT(3,0)="FILE: "_FNAME
70 S PSXTXT(4,0)="A copy of the file has been placed in the hold directory "_DIRHOLD
71 D ^XMD
72 I $E(IOST)="C" W ! F I=1:1:4 W !,PSXTXT(I,0) I I=4 H 3
73 K PSXTXT,DIRHOLD
74 Q
75RXNDX ; backfill the RX multiple RXNDX field #40 of file 552.4
76 S ORDDA=0 F S ORDDA=$O(^PSX(552.4,ORDDA)) Q:ORDDA'>0 D
77 . S SITE=$$GET1^DIQ(552.4,ORDDA,.01),SITE=$P(SITE,"-")
78 . S RXDA=0 F S RXDA=$O(^PSX(552.4,ORDDA,1,RXDA)) Q:RXDA'>0 S XX=^(RXDA,0) D
79 .. F YY="RXNM^1","FILL^12" D PIECE(XX,U,YY)
80 .. S FILL=FILL+1,VAL=SITE_"-"_RXNM_"-"_FILL
81 .. K DR,DIE,DA
82 .. S DIE="^PSX(552.4,"_ORDDA_",1,",DA(1)=ORDDA,DA=RXDA,DR="40///^S X=VAL"
83 .. D ^DIE K DR,DIE,DA
84 Q
Note: See TracBrowser for help on using the repository browser.