PRCB8A1 ;WISC/PLT-PRCB8A CONTINUED ; 08/16/95 3:29 PM
V ;;5.1;IFCAP;;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 is ^1 = FMS documents (fileman) date, ^2 = doc year, ^3 = doc quarter
; ^4 = SITE #
; ^5 = transfer from control point #, ^6 = $amount,
; ^7 = BBFY, ^8 = to fund control point #, ^9=fiscal accounting period (mmyy), ^10=Cal acct per
;PRCID=FMS document id if regenerated
ST(X,PRCFC,PRCID) ;ST auto document
N PRCA,PRCB,PRCC,PRCDDT,PRCF,PRCF1,PRCQ,PRCRI,PRCSITE,PRCY,GECSFMS,PRCAP
N A,B,Z
S PRCDDT=$P(PRCFC,"^"),PRCY=$P(PRCFC,"^",2),PRCQ=$P(PRCFC,"^",3)
S PRCSITE=+$P(PRCFC,"^",4),PRCRI(420.01)=+$P(PRCFC,"^",5),PRCAMT=$P(PRCFC,"^",6)
S PRCRI("420.01A")=$P(PRCFC,"^",8),PRCAP=$P(PRCFC,"^",9)_"/"_$P(PRCFC,"^",10)
I $G(PRCID)]"" S PRCRI(2100.1)=+PRCID,PRCID=$P(PRCID,"^",2)
I $G(PRCID)="" S (X,Z)=PRCSITE_"-FC" D EN1^PRCSUT3 S X="0000"_+$P(X,"-",3),PRCID=PRCSITE_"FC"_$E(X,$L(X)-3,$L(X))
S PRCY=$$YEAR^PRC0C(PRCY)+0
I $G(PRCRI(2100.1)) D REBUILD^GECSUFM1(PRCRI(2100.1),"I",$$SEC1^PRC0C(PRCSITE),"Y","Edited Rejected Auto ST 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,"ST",$$SEC1^PRC0C(PRCSITE),0,"Y","Original Auto ST Document")
. S PRCRI(2100.1)=GECSFMS("DA")
. QUIT
D SETPARAM^GECSSDCT(PRCRI(2100.1),$P($TR(PRCFC,"^","/"),"/",1,8)_"//"_PRCAP)
S PRCC=1,PRCB(PRCC)=""
D STDOC,DLM("~")
D STLIN,DLM("~{")
S PRCA="" F S PRCA=$O(PRCB(PRCA)) Q:'PRCA D SETCS^GECSSTAA(PRCRI(2100.1),PRCB(PRCA))
D SETSTAT^GECSSTAA(PRCRI(2100.1),"Q")
EXIT S X=$G(PRCRI(2100.1))_"^"_PRCID
QUIT
;
STDOC ;assemble ST doc
D DOCREQ^PRC0C("^"_PRCSITE_"^"_PRCRI(420.01)_"^"_$E(PRCY,3,4)_"^"_$P(PRCFC,"^",7),"SAB","PRCF")
D DOCREQ^PRC0C("^"_PRCSITE_"^"_PRCRI("420.01A")_"^"_$E(PRCY,3,4)_"^"_$P(PRCFC,"^",7),"SAB","PRCF1")
D STR("ST2",3),STR($E(PRCDDT,4,5),2),STR($E(PRCDDT,6,7),2),STR($E(PRCDDT,2,3),2)
D STR($E(PRCAP,1,2),2),STR($E(PRCAP,3,4),2),STR($E($P(PRCF,"^",6),3,4),2),STR($S($P(PRCF,"^",6)=$P(PRCF,"^",7):"",1:$E($P(PRCF,"^",7),3,4)),2)
D STR($P(PRCF,"^",5),6)
QUIT
;
STLIN ;assemble ST line
D STR("LIN",3),DLM("~"),STR("STA",3)
D STR($S($G(PRCF("AO"))="N":"",1:$P(PRCF,"^")),4)
D STR($S($G(PRCF("SITE"))="N":"",1:PRCSITE),7)
D STR($S($G(PRCF("FCPRJ"))="N":"",1:$P(PRCF,"^",3)),9)
D STR($S($G(PRCF("OC"))="N":"",1:$P(PRCF,"^",4)),4)
D STR(PRCQ,1)
S X=$$DATE^PRC0C(PRCDDT,"I"),X=$S(PRCY_"^"_PRCQ]$P(X,"^",1,2):"A",1:"Y") D STR(X,1)
D STR($S($G(PRCF1("AO"))="N":"",1:$P(PRCF1,"^")),4)
D STR($S($G(PRCF1("SITE"))="N":"",1:PRCSITE),7)
D STR($S($G(PRCF1("FCPRJ"))="N":"",1:$P(PRCF1,"^",3)),9)
D STR($S($G(PRCF1("OC"))="N":"",1:$P(PRCF1,"^",4)),4)
D STR(PRCQ,1),STR($FN(PRCAMT,"-",2),15)
QUIT
;
;
;A = data, B = field length
STR(A,B) ;store data in node/piece
S:$L(PRCB(PRCC))+$L(A)>230 PRCC=PRCC+1,PRCB(PRCC)=""
S PRCB(PRCC)=PRCB(PRCC)_$E(A,1,B)_"^"
QUIT
;
DLM(A) ;store seg ~ or txn { delimiters
S PRCB(PRCC)=PRCB(PRCC)_A
QUIT
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCB8A1 3183 printed Dec 13, 2024@02:00:30 Page 2
PRCB8A1 ;WISC/PLT-PRCB8A CONTINUED ; 08/16/95 3:29 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, 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 is ^1 = FMS documents (fileman) date, ^2 = doc year, ^3 = doc quarter
+6 ; ^4 = SITE #
+7 ; ^5 = transfer from control point #, ^6 = $amount,
+8 ; ^7 = BBFY, ^8 = to fund control point #, ^9=fiscal accounting period (mmyy), ^10=Cal acct per
+9 ;PRCID=FMS document id if regenerated
ST(X,PRCFC,PRCID) ;ST auto document
+1 NEW PRCA,PRCB,PRCC,PRCDDT,PRCF,PRCF1,PRCQ,PRCRI,PRCSITE,PRCY,GECSFMS,PRCAP
+2 NEW A,B,Z
+3 SET PRCDDT=$PIECE(PRCFC,"^")
SET PRCY=$PIECE(PRCFC,"^",2)
SET PRCQ=$PIECE(PRCFC,"^",3)
+4 SET PRCSITE=+$PIECE(PRCFC,"^",4)
SET PRCRI(420.01)=+$PIECE(PRCFC,"^",5)
SET PRCAMT=$PIECE(PRCFC,"^",6)
+5 SET PRCRI("420.01A")=$PIECE(PRCFC,"^",8)
SET PRCAP=$PIECE(PRCFC,"^",9)_"/"_$PIECE(PRCFC,"^",10)
+6 IF $GET(PRCID)]""
SET PRCRI(2100.1)=+PRCID
SET PRCID=$PIECE(PRCID,"^",2)
+7 IF $GET(PRCID)=""
SET (X,Z)=PRCSITE_"-FC"
DO EN1^PRCSUT3
SET X="0000"_+$PIECE(X,"-",3)
SET PRCID=PRCSITE_"FC"_$EXTRACT(X,$LENGTH(X)-3,$LENGTH(X))
+8 SET PRCY=$$YEAR^PRC0C(PRCY)+0
+9 IF $GET(PRCRI(2100.1))
DO REBUILD^GECSUFM1(PRCRI(2100.1),"I",$$SEC1^PRC0C(PRCSITE),"Y","Edited Rejected Auto ST Document")
+10 ;add entry in file 2100.1 if not rejected process
+11 if $GET(PRCRI(2100.1))=""
Begin DoDot:1
+12 DO CONTROL^GECSUFMS("I",PRCSITE,PRCID,"ST",$$SEC1^PRC0C(PRCSITE),0,"Y","Original Auto ST Document")
+13 SET PRCRI(2100.1)=GECSFMS("DA")
+14 QUIT
End DoDot:1
if PRCRI(2100.1)<1
GOTO EXIT
+15 DO SETPARAM^GECSSDCT(PRCRI(2100.1),$PIECE($TRANSLATE(PRCFC,"^","/"),"/",1,8)_"//"_PRCAP)
+16 SET PRCC=1
SET PRCB(PRCC)=""
+17 DO STDOC
DO DLM("~")
+18 DO STLIN
DO DLM("~{")
+19 SET PRCA=""
FOR
SET PRCA=$ORDER(PRCB(PRCA))
if 'PRCA
QUIT
DO SETCS^GECSSTAA(PRCRI(2100.1),PRCB(PRCA))
+20 DO SETSTAT^GECSSTAA(PRCRI(2100.1),"Q")
EXIT SET X=$GET(PRCRI(2100.1))_"^"_PRCID
+1 QUIT
+2 ;
STDOC ;assemble ST doc
+1 DO DOCREQ^PRC0C("^"_PRCSITE_"^"_PRCRI(420.01)_"^"_$EXTRACT(PRCY,3,4)_"^"_$PIECE(PRCFC,"^",7),"SAB","PRCF")
+2 DO DOCREQ^PRC0C("^"_PRCSITE_"^"_PRCRI("420.01A")_"^"_$EXTRACT(PRCY,3,4)_"^"_$PIECE(PRCFC,"^",7),"SAB","PRCF1")
+3 DO STR("ST2",3)
DO STR($EXTRACT(PRCDDT,4,5),2)
DO STR($EXTRACT(PRCDDT,6,7),2)
DO STR($EXTRACT(PRCDDT,2,3),2)
+4 DO STR($EXTRACT(PRCAP,1,2),2)
DO STR($EXTRACT(PRCAP,3,4),2)
DO STR($EXTRACT($PIECE(PRCF,"^",6),3,4),2)
DO STR($SELECT($PIECE(PRCF,"^",6)=$PIECE(PRCF,"^",7):"",1:$EXTRACT($PIECE(PRCF,"^",7),3,4)),2)
+5 DO STR($PIECE(PRCF,"^",5),6)
+6 QUIT
+7 ;
STLIN ;assemble ST line
+1 DO STR("LIN",3)
DO DLM("~")
DO STR("STA",3)
+2 DO STR($SELECT($GET(PRCF("AO"))="N":"",1:$PIECE(PRCF,"^")),4)
+3 DO STR($SELECT($GET(PRCF("SITE"))="N":"",1:PRCSITE),7)
+4 DO STR($SELECT($GET(PRCF("FCPRJ"))="N":"",1:$PIECE(PRCF,"^",3)),9)
+5 DO STR($SELECT($GET(PRCF("OC"))="N":"",1:$PIECE(PRCF,"^",4)),4)
+6 DO STR(PRCQ,1)
+7 SET X=$$DATE^PRC0C(PRCDDT,"I")
SET X=$SELECT(PRCY_"^"_PRCQ]$PIECE(X,"^",1,2):"A",1:"Y")
DO STR(X,1)
+8 DO STR($SELECT($GET(PRCF1("AO"))="N":"",1:$PIECE(PRCF1,"^")),4)
+9 DO STR($SELECT($GET(PRCF1("SITE"))="N":"",1:PRCSITE),7)
+10 DO STR($SELECT($GET(PRCF1("FCPRJ"))="N":"",1:$PIECE(PRCF1,"^",3)),9)
+11 DO STR($SELECT($GET(PRCF1("OC"))="N":"",1:$PIECE(PRCF1,"^",4)),4)
+12 DO STR(PRCQ,1)
DO STR($FNUMBER(PRCAMT,"-",2),15)
+13 QUIT
+14 ;
+15 ;
+16 ;A = data, B = field length
STR(A,B) ;store data in node/piece
+1 if $LENGTH(PRCB(PRCC))+$LENGTH(A)>230
SET PRCC=PRCC+1
SET PRCB(PRCC)=""
+2 SET PRCB(PRCC)=PRCB(PRCC)_$EXTRACT(A,1,B)_"^"
+3 QUIT
+4 ;
DLM(A) ;store seg ~ or txn { delimiters
+1 SET PRCB(PRCC)=PRCB(PRCC)_A
+2 QUIT
+3 ;
