PRCB8B ;WISC/PLT-AUTO GENERATE FMS VT-DOCUMENTS ;11/12/96 15:42
V ;;5.1;IFCAP;**71,142,173**;Oct 20, 2000;Build 9
;Per VHA Directive 2004-038, 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
L -^PRCH(440.7,PRCRI(440.7))
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("00",11,2) ;PRC*5.1*173 set sub CC to '00'
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCB8B 3559 printed Apr 09, 2024@21:08:25 Page 2
PRCB8B ;WISC/PLT-AUTO GENERATE FMS VT-DOCUMENTS ;11/12/96 15:42
V ;;5.1;IFCAP;**71,142,173**;Oct 20, 2000;Build 9
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;invalid entry
QUIT
+3 ;
+4 ;.X = record id of file 2100.1 if generated, "" if fail
+5 ;PRCFC data: ^1=ri of 440.7, ^2-...=date infor of prca from prcb1f
+6 ;PRCID data ^1=file 2100.1 ri, ^2= document id (if regenerated)
SV(X,PRCFC,PRCID) ;SV auto document
+1 NEW PRCA,PRCB,PRCC,PRCDDT,PRCF,PRCQ,PRCRI,PRCSITE,PRCY,GECSFMS,PRCLACT,PRCAP,PRCDD,PRCDATA,PRCAMT
+2 NEW PRCDI,PRCBOC,PRCEM,PRCIDL
+3 NEW A,B,Z
S SET PRCRI(440.7)=$PIECE(PRCFC,"^")
SET A=$PIECE(PRCFC,"^",12)
SET PRCSITE=$PIECE(A,"-",2)
+1 SET PRCEM="E"
IF $GET(PRCID)]""
SET PRCRI(2100.1)=+PRCID
SET PRCID=$PIECE(PRCID,"^",2)
+2 IF $GET(PRCID)=""
SET A=$PIECE(PRCFC,"^",12)
SET PRCID=PRCSITE_$EXTRACT(A,2,7)
SET PRCID=$EXTRACT(PRCID,1,3)_$TRANSLATE($EXTRACT(PRCID,4,7),"1234567890","ABCDEFGHIJ")_$EXTRACT(PRCID,8,999)
+3 IF $GET(PRCRI(2100.1))
DO REBUILD^GECSUFM1(PRCRI(2100.1),"I",$$SEC1^PRC0C(PRCSITE),"","Edited Rejected Auto SV Document")
+4 ;add entry in file 2100.1 if not rejected process
+5 if $GET(PRCRI(2100.1))=""
Begin DoDot:1
+6 DO CONTROL^GECSUFMS("I",PRCSITE,PRCID,"SV",$$SEC1^PRC0C(PRCSITE),$SELECT(PRCEM="M":1,1:0),"","Auto SV Document")
+7 SET PRCRI(2100.1)=GECSFMS("DA")
+8 QUIT
End DoDot:1
if PRCRI(2100.1)<1
GOTO EXIT
+9 DO SETPARAM^GECSSDCT(PRCRI(2100.1),$PIECE(PRCFC,"^")_"/"_$PIECE(PRCFC,"^",12))
+10 ;set sv2 segment
+11 SET (PRCRI(440.701),PRCAMT)=0
+12 FOR
SET PRCRI(440.701)=$ORDER(^PRCH(440.7,PRCRI(440.7),50,PRCRI(440.701)))
if 'PRCRI(440.701)
QUIT
SET PRCA=^(PRCRI(440.701),0)
IF $PIECE(PRCA,"^",5)=""&($PIECE(PRCA,"^",2)-$PIECE(PRCA,"^",3))!$PIECE(PRCA,"^",5)
Begin DoDot:1
+13 SET PRCAMT=$SELECT($PIECE(PRCA,"^",5)="":$PIECE(PRCA,"^",2)-$PIECE(PRCA,"^",3),1:$PIECE(PRCA,"^",5))+PRCAMT
+14 QUIT
End DoDot:1
+15 SET PRCB=$$SV2
DO SETCS^GECSSTAA(PRCRI(2100.1),PRCB)
+16 ;set line segemnt
+17 SET PRCRI(440.701)=0
FOR
SET PRCRI(440.701)=$ORDER(^PRCH(440.7,PRCRI(440.7),50,PRCRI(440.701)))
if 'PRCRI(440.701)
QUIT
SET PRCA=^(PRCRI(440.701),0)
SET PRCAMT=$SELECT($PIECE(PRCA,"^",5)="":$PIECE(PRCA,"^",2)-$PIECE(PRCA,"^",3),1:$PIECE(PRCA,"^",5))
if PRCAMT
Begin DoDot:1
+18 SET PRCB=$$LINE(PRCA)
DO SETCS^GECSSTAA(PRCRI(2100.1),PRCB)
+19 QUIT
End DoDot:1
+20 DO SETSTAT^GECSSTAA(PRCRI(2100.1),"Q")
EXIT SET X=$GET(PRCRI(2100.1))_"/"_PRCID
+1 LOCK -^PRCH(440.7,PRCRI(440.7))
+2 QUIT
+3 ;
SV2() ;create sv2
+1 NEW PRCDATA,A,B
+2 SET A=$$DATE^PRC0C($PIECE(PRCFC,"^",10)+40,"H")
+3 SET A=$$DATE^PRC0C($PIECE(A,"^",4)_"/1/"_$PIECE(A,"^",3),"E")
+4 DO PIECE($PIECE(A,"^",9),13,2)
DO PIECE($EXTRACT($PIECE(A,"^"),3,4),12,2)
+5 SET A=$$DATE^PRC0C(DT,"I")
+6 DO PIECE("SV2",1,3)
DO PIECE($EXTRACT($PIECE(A,"^",3),3,4),2,2)
DO PIECE($PIECE(A,"^",4),3,2)
DO PIECE($PIECE(A,"^",5),4,2)
+7 DO PIECE($PIECE(A,"^",9),5,2)
DO PIECE($EXTRACT($PIECE(A,"^"),3,4),6,2)
+8 SET B=$SELECT(PRCAMT<0:-PRCAMT,1:PRCAMT)
+9 DO PIECE(PRCEM,7,1)
DO PIECE($JUSTIFY(B,0,2),16,15)
+10 QUIT PRCDATA_"^~"
+11 ;
LINE(PRCA) ;assemble line
+1 NEW PRCDATA,PRCLIN,PRCSVA,PRCSVB,PRCREQ
+2 NEW A,B,C
+3 SET PRCLIN="LIN"
+4 SET PRCDATA="SVA"
+5 SET A=$$FUND^PRC0C($PIECE(PRCA,"/"),$PIECE(PRCA,"/",2))
+6 DO DOCREQ^PRC0C(+A,"SPE","PRCREQ")
+7 DO PIECE($EXTRACT(1000+PRCRI(440.701),2,4),2,3)
DO PIECE("CC",3,2)
+8 SET A=$ORDER(^PRCD(420.14,"UNQ",$PIECE(PRCA,"/"),$PIECE(PRCA,"/",2),1))
+9 DO PIECE($EXTRACT($PIECE(PRCA,"/",2),3,4),4,2)
if $PIECE(PRCA,"/",2)'=A
DO PIECE($EXTRACT(A,3,4),5,2)
+10 DO PIECE($PIECE(PRCA,"/"),6,6)
DO PIECE(PRCSITE,8,7)
+11 ;PRC*5.1*173 set sub CC to '00'
IF $GET(PRCREQ("CC"))'="N"
DO PIECE($PIECE(PRCA,"/",5),10,7)
DO PIECE("00",11,2)
+12 DO PIECE($PIECE(PRCA,"/",4),12,9)
DO PIECE($PIECE(PRCA,"/",6),13,4)
+13 DO PIECE(220,23,4)
+14 SET PRCSVA=PRCDATA
+15 SET PRCDATA="SVB"
+16 SET A=$SELECT(PRCAMT<0:-PRCAMT,1:PRCAMT)
+17 DO PIECE($JUSTIFY(A,0,2),2,15)
DO PIECE($SELECT(PRCAMT<0:"D",1:"I"),3,1)
DO PIECE("E",5,1)
+18 SET PRCSVB=PRCDATA
+19 QUIT PRCLIN_"^~"_PRCSVA_"^~"_PRCSVB_"^~"
PIECE(A,B,C) ;set piece in variable PRCDATA, A-VALUE, B-PPECE #, C-LENGTH
+1 SET $PIECE(PRCDATA,"^",B)=$EXTRACT(A,1,C)
+2 QUIT
