source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFARR.m@ 1078

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

initial load of WorldVistAEHR

File size: 5.8 KB
Line 
1PRCFARR ;ISC-SF/TKW/LKG-BUILD RECEIVING REPORT FOR ELECTRONIC TRANSMISSION TO AUSTIN ;11/22/95 12:15
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4ENRT ;RE-TRANSMIT RR ON DEMAND
5 S DIC="^PRC(442,",DIC(0)="AEQM",DIC("S")="I $O(^PRC(442,+Y,11,0))" D ^DIC K DIC G:Y=-1 EX^PRCFARR3 S PRCFPO=+Y
6 S DIC="^PRC(442,"_PRCFPO_",11,",DA(1)=PRCFPO,DIC(0)="AEQM",DIC("S")="I $P(^(0),""^"",19)'=""""" D ^DIC K DIC G:Y=-1 EX^PRCFARR3 S PRCFPR=+Y
7EN ; ENTRY POINT FOR AUTOMATIC TRANSMISSION
8 K ^TMP("PRCFARR",$J) N D0
9 Q:'$D(PRCFPO)!('$D(PRCFPR)) Q:'$D(^PRC(442,+PRCFPO,0))
10 S PRCF0=^PRC(442,PRCFPO,0),PRCF1=$G(^(1)),PRCF12=$G(^(12)),PRCF17=$G(^(17)),PRCF18=$G(^(18)),PRCF11=^PRC(442,PRCFPO,11,PRCFPR,0),PRCFPRD=+PRCF11
11 S PRCF10=$G(^PRC(442,PRCFPO,10,1,0)),PRCFTC=$S(PRCF10]"":$P($P(PRCF10,U),"."),1:"")
12 S:PRCFTC'?2U PRCFTC=$S($P(PRCF0,U,2)=2:"SO",1:"MO")
13 S PRCFOBNO=$TR($P(PRCF0,U),"-"),PRCFOBNO=PRCFOBNO_$E(" ",1,11-$L(PRCFOBNO))
14 N FED,STA,FCP,DFY,BBFY,P2237,REQ,NET S STA=+PRCF0,FCP=+$P(PRCF0,U,3)
15 S P2237=$P(PRCF0,U,12),DFY=$S(P2237?1.N:$P($P($G(^PRCS(410,P2237,0)),U),"-",2),1:""),REQ=""
16 S BBFY=$P($G(^PRC(442,PRCFPO,23)),U,2) S:BBFY BBFY=1700+$E(BBFY,1,3)
17 I STA,DFY,FCP,'BBFY S BBFY=$$BBFY^PRCSUT(STA,DFY,FCP)
18 I STA,FCP,DFY,BBFY S REQ=$$ACC^PRC0C(STA,FCP_U_DFY_U_BBFY)
19 S NET=1 I $P(REQ,U,12)="G" S NET=0
20 N PRCACT,PRCFBNO S PRCACT="E",PRCFBNO="",LCKFLG=0
21 I +$P(PRCF11,U,3)<0!(+$P(PRCF11,U,5)<0) D Q:LCKFLG
22 . S PRCACT="M" D GETBN(+PRCF0,.PRCFBNO) Q:LCKFLG
23 . S:$P(^PRC(442,PRCFPO,11,PRCFPR,0),U,20)="" $P(^(0),U,20)=PRCFBNO
24 . S PRCFBNO=+PRCF0_$E(1000+PRCFBNO,2,4)
25 I $P(PRCF0,"^",8),$P(PRCF0,"^",8)<$P(PRCF0,"^",6) S $P(PRCF0,"^",6,9)=$P(PRCF0,"^",8,9)_"^"_$P(PRCF0,"^",6,7)
26 I '$D(PRCFJDN) S X=$P(PRCF1,"^",15) D JDN^PRCUTL S PRCFJDN=Y
27 ;N PNO S PNO="00"_PRCFPR,PNO=$E(PNO,$L(PNO)-1,$L(PNO)) ; Partial #
28 N PNO S PNO="" S X=$S(PRCACT="M"&($P($G(^PRC(442,PRCFPO,11,PRCFPR,1)),U,16)?1.N):$P(^(1),U,16),1:PRCFPR)
29 D ALPHA^PRCFPAR(X,.PNO) ; IFCAP ==> FMS Partial #
30 I PNO<0 D G EX^PRCFARR3
31 . S X="Partial # is out of limits - FMS will not process.*"
32 . D MSG^PRCFQ
33 . Q
34 S FED=0 I $P(PRCF1,U,7)]"","13578"[$P(PRCF1,U,7) S FED=2
35 N SPLIT S SPLIT=$S(FED:"A",1:" ")
36 S:FED AGYCD=$P(^PRCD(420.8,$P(PRCF1,U,7),0),U,5)
37 N SEC1 S SEC1=$E($$SEC1^PRC0C(PRC("SITE"))_" ",1,4)
38S1 ;#1 SPLIT,STATION,PAT,PARTIAL NO.,PARTIAL DATE,JULIAN DATE,LINE/ITEM COUNT,CASCA PROJECT #,TRANS TYPE,SEC1,BATCH#,REF TRANS CODE & #,DOC ACTION
39 S TMP=SPLIT_"^1^"_+PRCF0_"^"_$P($P(PRCF0,"^",1),"-",2)_"^"_PNO_"^"_$E(PRCF11,4,7)_$E(PRCF11,2,3)_"^"_$P(PRCF0,"^",14)_"^"
40 S:FED TMP=TMP_AGYCD_U_PRCFJDN_U_$P(PRCF18,U,13)_U_$P(PRCF18,U,14)_U
41 S TMP=TMP_SEC1_U_PRCFBNO_U_PRCFTC_U_PRCFOBNO_U_PRCACT_U_"001"_U
42 S ^TMP("PRCFARR",$J,1,0)=TMP
43S2 ;#2 VENDOR NAME, ADDRESS, PHONE
44 S PRCFX="",X=$G(^PRC(440,+PRCF1,0)),$P(PRCFX,"^",1,6)="2^"_$P(X,"^",1,5),$P(PRCFX,"^",7)=$E($P(X,"^",6),1,19)_" "_$S($D(^DIC(5,+$P(X,"^",7),0)):$P(^(0),"^",2),1:"")_" "_$P(X,"^",8),$P(PRCFX,"^",8)=$E($P(X,"^",10),1,18)
45 N VN S VN=$P(PRCFX,U,2),$P(PRCFX,U,2)=$E(VN,1,30)
46 S ^TMP("PRCFARR",$J,2,0)=PRCFX_"^"
47S3 ;#3 SHIP TO ADDRESS
48 S D0=PRCFPO,(X,PRCFX)=""
49 I +$P(PRCF0,"^",2)'=4 D
50 . S PRC("SITE")=+PRCF0 D FTYP^PRCHFPNT
51 . S X=$S($P($G(^PRC(442,PRCFPO,23)),U,7)]"":$P(^(23),U,7),1:+PRCF0)
52 . S X=$S($D(^PRC(411,X,1,+$P(PRCF1,"^",3),0)):^(0),1:"")
53 . S:X]"" $P(X,"^")=$P(X,"^")_"^"_$E(PRCHFTYP,1,24)
54 I +$P(PRCF0,"^",2)=4,$P(PRCF1,"^",12)]"" S X=$S($D(^PRC(440.2,$P(PRCF1,"^",12),0)):^(0),1:"") S:X]"" $P(X,"^")=$S($D(^DPT(+X,0)):$E($P(^(0),"^",1),1,21),1:+X),$P(X,"^",4)=$P(X,"^",4)_"^"
55 S $P(PRCFX,"^",1,6)="3^"_$E($P(X,"^",1),1,30)_"^"_$P(X,"^",2,5),$P(PRCFX,"^",7)=$P(X,"^",6)_" "_$S($D(^DIC(5,+$P(X,"^",7),0)):$P(^(0),"^",2),1:"")_" "_$P(X,"^",8),^TMP("PRCFARR",$J,3,0)=PRCFX_"^"
56S4 ;#4 REQ.SERVICE,GBL#,TYPE OF ORDER,PROPOSAL,CONTRACT(S)
57 S Y=$S($D(^PRCD(420.8,+$P(PRCF1,"^",7),0)):$P(^(0),"^"),1:""),Y=$S(Y=2:"P",Y?1"B":Y,1:"D")
58 S Z="^^",(X,Z1)="" F I=1:1:3 S X=$O(^PRC(442,PRCFPO,2,"AC",X)) Q:X="" S:$O(^(X,0)) Z1=^($O(^(0))) S $P(Z,"^",I)=Z1_X,Z1=""
59 S X=$S($D(^DIC(49,+$P(PRCF1,"^",2),0)):^(0),1:""),Z1=$S($P(X,"^",8)]"":"("_$P(X,"^",8)_")",1:""),X=$E($P(X,"^"),1,(30-$L(Z1)))_Z1,Z1=""
60 S ^TMP("PRCFARR",$J,4,0)="4^"_X_"^"_$P(PRCF12,"^",7)_"^"_Y_"^"_$P(PRCF1,"^",8)_"^"_Z_"^",$P(^(0),U,9)=""
61 G EN^PRCFARR0
62FAMT I 'X S X="" Q
63 S X=$P(X,".")_$E($P(X,".",2)_"00",1,2) Q
64W1 W !!,"Receiving Report is incomplete. Cannot transmit!",$C(7) Q
65GETBN(PRCSTA,PRCX) ;Get Batch #
66 N PRCFDA,X,Y
67 I $P(^PRC(442,PRCFPO,11,PRCFPR,0),U,20)]"" S PRCX=$P(^(0),U,20) Q
68 S X=PRCSTA_"-RRT-00",DIC=422.2,DIC(0)="XL",DLAYGO=422.2 D ^DIC K DIC,DLAYGO
69 I +Y<1 S PRCX=-1 Q
70 S PRCFDA=+Y
71 I $G(PRCFA8)=1 D LOCK KILL PRCFA8 QUIT
72 D LOCK1 QUIT
73 ;
74LOCK ;Process Receiving Report Option.
75 L +^PRCF(422.2,PRCFDA):3
76 E D Q:LCKFLG
77 . S LCKFLG=1
78 . DO EN^DDIOL("Record in use please try later.") Q
79 ;
80 I +$P(Y,U,3) S $P(^PRCF(422.2,PRCFDA,0),U,2)=500
81 S PRCX=$P($G(^PRCF(422.2,PRCFDA,0)),U,2)+1
82 S:PRCX>999 PRCX=1 S $P(^PRCF(422.2,PRCFDA,0),U,2)=PRCX
83 L -^PRCF(422.2,PRCFDA)
84 Q
85 ;
86LOCK1 ;Get LOCK for tasked process. If unable to obtain a LOCK
87 ;after 5 minutes (300 seconds) exit and give the user an email.
88 L +^PRCF(422.2,PRCFDA):300
89 E D LCKMSG S LCKFLG=1 Q
90 ;
91 I +$P(Y,U,3) S $P(^PRCF(422.2,PRCFDA,0),U,2)=500
92 S PRCX=$P($G(^PRCF(422.2,PRCFDA,0)),U,2)+1
93 S:PRCX>999 PRCX=1 S $P(^PRCF(422.2,PRCFDA,0),U,2)=PRCX
94 L -^PRCF(422.2,PRCFDA)
95 Q
96 ;
97LCKMSG ;Send user a message
98 N XMDUZ,MSG,MSG1
99 S MSG="Error: Receiving Report NOT queued, "
100 S MSG=MSG_"unable to obtain the batch transaction "
101 S MSG1=" number. Please try again."
102 K ^TMP("PRCFARR",$J)
103 S ^TMP("PRCFARR",$J,1,0)=MSG
104 S ^TMP("PRCFARR",$J,2,0)=MSG1
105 S XMDUZ=$S($D(DUZ)#2:DUZ,1:.5)
106 S XMY(XMDUZ)=""
107 S XMSUB="RECEIVING REPORT "_$P(^PRC(442,PRCFA("PODA"),0),"^",1)
108 S XMSUB=XMSUB_" PARTIAL #: "_PRCFA("PARTIAL")
109 S XMTEXT="^TMP(""PRCFARR"","_$J_","
110 S XMY(XMDUZ)=""
111 D ^XMD
112 K ^TMP("PRCFARR",$J)
113 Q
Note: See TracBrowser for help on using the repository browser.