- PRCB8A ;WISC/PLT-AUTO GENERATE FMS DOCUMENTS ; 08/16/95 3:30 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=fund control point #, ^6=$amount, ^7=BBFY
- ; ^8=fcp # if from AT, ^9=fiscal accounting period mmyy, ^10=cal acct per
- ;PRCID data ^1=file 2100.1 ri, ^2= document id if regenerated
- SA(X,PRCFC,PRCID) ;SA auto document
- N PRCA,PRCB,PRCC,PRCDDT,PRCF,PRCQ,PRCRI,PRCSITE,PRCY,GECSFMS,PRCLACT,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),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
- D ;get required fields data and line action code
- . D DOCREQ^PRC0C("^"_PRCSITE_"^"_PRCRI(420.01)_"^"_$E(PRCY,3,4)_"^"_$P(PRCFC,"^",7),"SAB","PRCF")
- . S A=$$FMSACC^PRC0D(PRCSITE,PRCF),B=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_A_""",",0)
- . I B S PRCLACT="C"
- . E S A=$$A420D141^PRC0F(A,$P(PRCFC,"^",5)),PRCLACT="C"
- . QUIT
- I $G(PRCRI(2100.1)) D REBUILD^GECSUFM1(PRCRI(2100.1),"I",$$SEC1^PRC0C(PRCSITE),"Y","Edited Rejected Auto SA 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,"SA",$$SEC1^PRC0C(PRCSITE),0,"Y","Original Auto SA Document")
- . S PRCRI(2100.1)=GECSFMS("DA")
- . QUIT
- D SETPARAM^GECSSDCT(PRCRI(2100.1),$P($TR(PRCFC,"^","/"),"/",1,8)_"/"_PRCLACT_"/"_PRCAP)
- S PRCC=1,PRCB(PRCC)=""
- D SADOC,DLM("~")
- D SALIN,DLM("~{")
- S PRCA="" F S PRCA=$O(PRCB(PRCA)) Q:'PRCA D SETCS^GECSSTAA(PRCRI(2100.1),PRCB(PRCA))
- D:PRCLACT="A" SETCODE^GECSSDCT(PRCRI(2100.1),"D SAREJ^PRCB1C")
- D SETSTAT^GECSSTAA(PRCRI(2100.1),"Q")
- EXIT S X=$G(PRCRI(2100.1))_"^"_PRCID
- QUIT
- ;
- SADOC ;assemble SA doc
- D STR("SA2",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("01",2),STR($P(PRCF,"^",5),6),STR($FN(PRCAMT,"-",2),12)
- S X=$$DATE^PRC0C(PRCDDT,"I"),X=$S(PRCY_"^"_PRCQ]$P(X,"^",1,2):"DA",1:"DP")
- D STR(X,2),STR("02",2)
- D STR($S(X="DP":"03",1:""),2),STR("",1)
- QUIT
- ;
- SALIN ;assemble SA line
- D STR("LIN",3),DLM("~"),STR("SAA",3),STR(PRCLACT,1)
- D STR($S($G(PRCF("SITE"))="N":"",1:PRCSITE),7)
- 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)
- F A=6,12,12,12,12 D STR("",A)
- F A=1:1:4 D STR($S(PRCQ=A:$FN(PRCAMT,"-",2),1:""),12)
- F A=30,1 D STR("",30)
- F A=1:1:4 D STR($S(PRCQ=A&(PRCAMT<0):"D",PRCQ=A:"I",1:""),12)
- D STR("",1)
- 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[HPRCB8A 3416 printed Feb 18, 2025@23:26:52 Page 2
- PRCB8A ;WISC/PLT-AUTO GENERATE FMS DOCUMENTS ; 08/16/95 3:30 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 #, ^5=fund control point #, ^6=$amount, ^7=BBFY
- +7 ; ^8=fcp # if from AT, ^9=fiscal accounting period mmyy, ^10=cal acct per
- +8 ;PRCID data ^1=file 2100.1 ri, ^2= document id if regenerated
- SA(X,PRCFC,PRCID) ;SA auto document
- +1 NEW PRCA,PRCB,PRCC,PRCDDT,PRCF,PRCQ,PRCRI,PRCSITE,PRCY,GECSFMS,PRCLACT,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)
- SET PRCAP=$PIECE(PRCFC,"^",9)_"/"_$PIECE(PRCFC,"^",10)
- +5 IF $GET(PRCID)]""
- SET PRCRI(2100.1)=+PRCID
- SET PRCID=$PIECE(PRCID,"^",2)
- +6 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))
- +7 SET PRCY=$$YEAR^PRC0C(PRCY)+0
- +8 ;get required fields data and line action code
- Begin DoDot:1
- +9 DO DOCREQ^PRC0C("^"_PRCSITE_"^"_PRCRI(420.01)_"^"_$EXTRACT(PRCY,3,4)_"^"_$PIECE(PRCFC,"^",7),"SAB","PRCF")
- +10 SET A=$$FMSACC^PRC0D(PRCSITE,PRCF)
- SET B=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_A_""",",0)
- +11 IF B
- SET PRCLACT="C"
- +12 IF '$TEST
- SET A=$$A420D141^PRC0F(A,$PIECE(PRCFC,"^",5))
- SET PRCLACT="C"
- +13 QUIT
- End DoDot:1
- +14 IF $GET(PRCRI(2100.1))
- DO REBUILD^GECSUFM1(PRCRI(2100.1),"I",$$SEC1^PRC0C(PRCSITE),"Y","Edited Rejected Auto SA Document")
- +15 ;add entry in file 2100.1 if not rejected process
- +16 if $GET(PRCRI(2100.1))=""
- Begin DoDot:1
- +17 DO CONTROL^GECSUFMS("I",PRCSITE,PRCID,"SA",$$SEC1^PRC0C(PRCSITE),0,"Y","Original Auto SA Document")
- +18 SET PRCRI(2100.1)=GECSFMS("DA")
- +19 QUIT
- End DoDot:1
- if PRCRI(2100.1)<1
- GOTO EXIT
- +20 DO SETPARAM^GECSSDCT(PRCRI(2100.1),$PIECE($TRANSLATE(PRCFC,"^","/"),"/",1,8)_"/"_PRCLACT_"/"_PRCAP)
- +21 SET PRCC=1
- SET PRCB(PRCC)=""
- +22 DO SADOC
- DO DLM("~")
- +23 DO SALIN
- DO DLM("~{")
- +24 SET PRCA=""
- FOR
- SET PRCA=$ORDER(PRCB(PRCA))
- if 'PRCA
- QUIT
- DO SETCS^GECSSTAA(PRCRI(2100.1),PRCB(PRCA))
- +25 if PRCLACT="A"
- DO SETCODE^GECSSDCT(PRCRI(2100.1),"D SAREJ^PRCB1C")
- +26 DO SETSTAT^GECSSTAA(PRCRI(2100.1),"Q")
- EXIT SET X=$GET(PRCRI(2100.1))_"^"_PRCID
- +1 QUIT
- +2 ;
- SADOC ;assemble SA doc
- +1 DO STR("SA2",3)
- DO STR($EXTRACT(PRCDDT,4,5),2)
- DO STR($EXTRACT(PRCDDT,6,7),2)
- DO STR($EXTRACT(PRCDDT,2,3),2)
- +2 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)
- +3 DO STR("01",2)
- DO STR($PIECE(PRCF,"^",5),6)
- DO STR($FNUMBER(PRCAMT,"-",2),12)
- +4 SET X=$$DATE^PRC0C(PRCDDT,"I")
- SET X=$SELECT(PRCY_"^"_PRCQ]$PIECE(X,"^",1,2):"DA",1:"DP")
- +5 DO STR(X,2)
- DO STR("02",2)
- +6 DO STR($SELECT(X="DP":"03",1:""),2)
- DO STR("",1)
- +7 QUIT
- +8 ;
- SALIN ;assemble SA line
- +1 DO STR("LIN",3)
- DO DLM("~")
- DO STR("SAA",3)
- DO STR(PRCLACT,1)
- +2 DO STR($SELECT($GET(PRCF("SITE"))="N":"",1:PRCSITE),7)
- +3 DO STR($SELECT($GET(PRCF("AO"))="N":"",1:$PIECE(PRCF,"^")),4)
- +4 DO STR($SELECT($GET(PRCF("SITE"))="N":"",1:PRCSITE),7)
- +5 DO STR($SELECT($GET(PRCF("FCPRJ"))="N":"",1:$PIECE(PRCF,"^",3)),9)
- +6 DO STR($SELECT($GET(PRCF("OC"))="N":"",1:$PIECE(PRCF,"^",4)),4)
- +7 FOR A=6,12,12,12,12
- DO STR("",A)
- +8 FOR A=1:1:4
- DO STR($SELECT(PRCQ=A:$FNUMBER(PRCAMT,"-",2),1:""),12)
- +9 FOR A=30,1
- DO STR("",30)
- +10 FOR A=1:1:4
- DO STR($SELECT(PRCQ=A&(PRCAMT<0):"D",PRCQ=A:"I",1:""),12)
- +11 DO STR("",1)
- +12 QUIT
- +13 ;
- +14 ;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 ;