- 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 Mar 13, 2025@21:05:20 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
