source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCB8B.m@ 1607

PRCB8B ;WISC/PLT-AUTO GENERATE FMS VT-DOCUMENTS ;11/12/96  15:42
V ;;5.1;IFCAP;**71**;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 QUIT  ;invalid entry
 ;
 ;.X = record id of file 2100.1 if generated, "" if fail
 ;PRCFC data: ^1=ri of 440.7, ^2-...=date infor of prca from prcb1f
 ;PRCID data ^1=file 2100.1 ri, ^2= document id (if regenerated)
SV(X,PRCFC,PRCID) ;SV auto document
 N PRCA,PRCB,PRCC,PRCDDT,PRCF,PRCQ,PRCRI,PRCSITE,PRCY,GECSFMS,PRCLACT,PRCAP,PRCDD,PRCDATA,PRCAMT
 N PRCDI,PRCBOC,PRCEM,PRCIDL
 N A,B,Z
S S PRCRI(440.7)=$P(PRCFC,"^"),A=$P(PRCFC,"^",12),PRCSITE=$P(A,"-",2)
 S PRCEM="E" I $G(PRCID)]"" S PRCRI(2100.1)=+PRCID,PRCID=$P(PRCID,"^",2)
 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)
 I $G(PRCRI(2100.1)) D REBUILD^GECSUFM1(PRCRI(2100.1),"I",$$SEC1^PRC0C(PRCSITE),"","Edited Rejected Auto SV Document")
 ;add entry in file 2100.1 if not rejected process
 D:$G(PRCRI(2100.1))=""  G EXIT:PRCRI(2100.1)<1
 . D CONTROL^GECSUFMS("I",PRCSITE,PRCID,"SV",$$SEC1^PRC0C(PRCSITE),$S(PRCEM="M":1,1:0),"","Auto SV Document")
 . S PRCRI(2100.1)=GECSFMS("DA")
 . QUIT
 D SETPARAM^GECSSDCT(PRCRI(2100.1),$P(PRCFC,"^")_"/"_$P(PRCFC,"^",12))
 ;set sv2 segment
 S (PRCRI(440.701),PRCAMT)=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) I $P(PRCA,"^",5)=""&($P(PRCA,"^",2)-$P(PRCA,"^",3))!$P(PRCA,"^",5) D
 . S PRCAMT=$S($P(PRCA,"^",5)="":$P(PRCA,"^",2)-$P(PRCA,"^",3),1:$P(PRCA,"^",5))+PRCAMT
 . QUIT
 S PRCB=$$SV2 D SETCS^GECSSTAA(PRCRI(2100.1),PRCB)
 ;set line segemnt
 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
 . S PRCB=$$LINE(PRCA) D SETCS^GECSSTAA(PRCRI(2100.1),PRCB)
 . QUIT
 D SETSTAT^GECSSTAA(PRCRI(2100.1),"Q")
EXIT S X=$G(PRCRI(2100.1))_"/"_PRCID
 QUIT
 ;
SV2() ;create sv2
 N PRCDATA,A,B
 S A=$$DATE^PRC0C($P(PRCFC,"^",10)+40,"H")
 S A=$$DATE^PRC0C($P(A,"^",4)_"/1/"_$P(A,"^",3),"E")
 D PIECE($P(A,"^",9),13,2),PIECE($E($P(A,"^"),3,4),12,2)
 S A=$$DATE^PRC0C(DT,"I")
 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)
 D PIECE($P(A,"^",9),5,2),PIECE($E($P(A,"^"),3,4),6,2)
 S B=$S(PRCAMT<0:-PRCAMT,1:PRCAMT)
 D PIECE(PRCEM,7,1),PIECE($J(B,0,2),16,15)
 QUIT PRCDATA_"^~"
 ;
LINE(PRCA) ;assemble line
 N PRCDATA,PRCLIN,PRCSVA,PRCSVB,PRCREQ
 N A,B,C
 S PRCLIN="LIN"
 S PRCDATA="SVA"
 S A=$$FUND^PRC0C($P(PRCA,"/"),$P(PRCA,"/",2))
 D DOCREQ^PRC0C(+A,"SPE","PRCREQ")
 D PIECE($E(1000+PRCRI(440.701),2,4),2,3),PIECE("CC",3,2)
 S A=$O(^PRCD(420.14,"UNQ",$P(PRCA,"/"),$P(PRCA,"/",2),1))
 D PIECE($E($P(PRCA,"/",2),3,4),4,2) D:$P(PRCA,"/",2)'=A PIECE($E(A,3,4),5,2)
 D PIECE($P(PRCA,"/"),6,6),PIECE(PRCSITE,8,7)
 I $G(PRCREQ("CC"))'="N" D PIECE($P(PRCA,"/",5),10,7),PIECE($E($P(PRCA,"/",5),5,6),11,2)
 D PIECE($P(PRCA,"/",4),12,9),PIECE($P(PRCA,"/",6),13,4)
 D PIECE(220,23,4)
 S PRCSVA=PRCDATA
 S PRCDATA="SVB"
 S A=$S(PRCAMT<0:-PRCAMT,1:PRCAMT)
 D PIECE($J(A,0,2),2,15),PIECE($S(PRCAMT<0:"D",1:"I"),3,1),PIECE("E",5,1)
 S PRCSVB=PRCDATA
 QUIT PRCLIN_"^~"_PRCSVA_"^~"_PRCSVB_"^~"
 ;
PIECE(A,B,C) ;set piece in variable PRCDATA, A-VALUE, B-PPECE #, C-LENGTH
 S $P(PRCDATA,"^",B)=$E(A,1,C)
 QUIT