source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCB8B.m@ 1582

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

initial load of WorldVistAEHR

File size: 3.3 KB
Line 
1PRCB8B ;WISC/PLT-AUTO GENERATE FMS VT-DOCUMENTS ;11/12/96 15:42
2V ;;5.1;IFCAP;**71**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 QUIT ;invalid entry
5 ;
6 ;.X = record id of file 2100.1 if generated, "" if fail
7 ;PRCFC data: ^1=ri of 440.7, ^2-...=date infor of prca from prcb1f
8 ;PRCID data ^1=file 2100.1 ri, ^2= document id (if regenerated)
9SV(X,PRCFC,PRCID) ;SV auto document
10 N PRCA,PRCB,PRCC,PRCDDT,PRCF,PRCQ,PRCRI,PRCSITE,PRCY,GECSFMS,PRCLACT,PRCAP,PRCDD,PRCDATA,PRCAMT
11 N PRCDI,PRCBOC,PRCEM,PRCIDL
12 N A,B,Z
13S S PRCRI(440.7)=$P(PRCFC,"^"),A=$P(PRCFC,"^",12),PRCSITE=$P(A,"-",2)
14 S PRCEM="E" I $G(PRCID)]"" S PRCRI(2100.1)=+PRCID,PRCID=$P(PRCID,"^",2)
15 I $G(PRCID)="" S A=$P(PRCFC,"^",12),PRCID=PRCSITE_$E(A,2,7),PRCID=$E(PRCID,1,3)_$TR($E(PRCID,4,7),"1234567890","ABCDEFGHIJ")_$E(PRCID,8,999)
16 I $G(PRCRI(2100.1)) D REBUILD^GECSUFM1(PRCRI(2100.1),"I",$$SEC1^PRC0C(PRCSITE),"","Edited Rejected Auto SV Document")
17 ;add entry in file 2100.1 if not rejected process
18 D:$G(PRCRI(2100.1))="" G EXIT:PRCRI(2100.1)<1
19 . D CONTROL^GECSUFMS("I",PRCSITE,PRCID,"SV",$$SEC1^PRC0C(PRCSITE),$S(PRCEM="M":1,1:0),"","Auto SV Document")
20 . S PRCRI(2100.1)=GECSFMS("DA")
21 . QUIT
22 D SETPARAM^GECSSDCT(PRCRI(2100.1),$P(PRCFC,"^")_"/"_$P(PRCFC,"^",12))
23 ;set sv2 segment
24 S (PRCRI(440.701),PRCAMT)=0
25 F S PRCRI(440.701)=$O(^PRCH(440.7,PRCRI(440.7),50,PRCRI(440.701))) QUIT:'PRCRI(440.701) S PRCA=^(PRCRI(440.701),0) I $P(PRCA,"^",5)=""&($P(PRCA,"^",2)-$P(PRCA,"^",3))!$P(PRCA,"^",5) D
26 . S PRCAMT=$S($P(PRCA,"^",5)="":$P(PRCA,"^",2)-$P(PRCA,"^",3),1:$P(PRCA,"^",5))+PRCAMT
27 . QUIT
28 S PRCB=$$SV2 D SETCS^GECSSTAA(PRCRI(2100.1),PRCB)
29 ;set line segemnt
30 S PRCRI(440.701)=0 F S PRCRI(440.701)=$O(^PRCH(440.7,PRCRI(440.7),50,PRCRI(440.701))) QUIT:'PRCRI(440.701) S PRCA=^(PRCRI(440.701),0),PRCAMT=$S($P(PRCA,"^",5)="":$P(PRCA,"^",2)-$P(PRCA,"^",3),1:$P(PRCA,"^",5)) D:PRCAMT
31 . S PRCB=$$LINE(PRCA) D SETCS^GECSSTAA(PRCRI(2100.1),PRCB)
32 . QUIT
33 D SETSTAT^GECSSTAA(PRCRI(2100.1),"Q")
34EXIT S X=$G(PRCRI(2100.1))_"/"_PRCID
35 QUIT
36 ;
37SV2() ;create sv2
38 N PRCDATA,A,B
39 S A=$$DATE^PRC0C($P(PRCFC,"^",10)+40,"H")
40 S A=$$DATE^PRC0C($P(A,"^",4)_"/1/"_$P(A,"^",3),"E")
41 D PIECE($P(A,"^",9),13,2),PIECE($E($P(A,"^"),3,4),12,2)
42 S A=$$DATE^PRC0C(DT,"I")
43 D PIECE("SV2",1,3),PIECE($E($P(A,"^",3),3,4),2,2),PIECE($P(A,"^",4),3,2),PIECE($P(A,"^",5),4,2)
44 D PIECE($P(A,"^",9),5,2),PIECE($E($P(A,"^"),3,4),6,2)
45 S B=$S(PRCAMT<0:-PRCAMT,1:PRCAMT)
46 D PIECE(PRCEM,7,1),PIECE($J(B,0,2),16,15)
47 QUIT PRCDATA_"^~"
48 ;
49LINE(PRCA) ;assemble line
50 N PRCDATA,PRCLIN,PRCSVA,PRCSVB,PRCREQ
51 N A,B,C
52 S PRCLIN="LIN"
53 S PRCDATA="SVA"
54 S A=$$FUND^PRC0C($P(PRCA,"/"),$P(PRCA,"/",2))
55 D DOCREQ^PRC0C(+A,"SPE","PRCREQ")
56 D PIECE($E(1000+PRCRI(440.701),2,4),2,3),PIECE("CC",3,2)
57 S A=$O(^PRCD(420.14,"UNQ",$P(PRCA,"/"),$P(PRCA,"/",2),1))
58 D PIECE($E($P(PRCA,"/",2),3,4),4,2) D:$P(PRCA,"/",2)'=A PIECE($E(A,3,4),5,2)
59 D PIECE($P(PRCA,"/"),6,6),PIECE(PRCSITE,8,7)
60 I $G(PRCREQ("CC"))'="N" D PIECE($P(PRCA,"/",5),10,7),PIECE($E($P(PRCA,"/",5),5,6),11,2)
61 D PIECE($P(PRCA,"/",4),12,9),PIECE($P(PRCA,"/",6),13,4)
62 D PIECE(220,23,4)
63 S PRCSVA=PRCDATA
64 S PRCDATA="SVB"
65 S A=$S(PRCAMT<0:-PRCAMT,1:PRCAMT)
66 D PIECE($J(A,0,2),2,15),PIECE($S(PRCAMT<0:"D",1:"I"),3,1),PIECE("E",5,1)
67 S PRCSVB=PRCDATA
68 QUIT PRCLIN_"^~"_PRCSVA_"^~"_PRCSVB_"^~"
69 ;
70PIECE(A,B,C) ;set piece in variable PRCDATA, A-VALUE, B-PPECE #, C-LENGTH
71 S $P(PRCDATA,"^",B)=$E(A,1,C)
72 QUIT
Note: See TracBrowser for help on using the repository browser.