PRCSEM2 ;WISC/KMB-RESET APPROPRIATION ENTRIES ; 7/23/96
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
N Z,Z1,Z2,F,F1
S Z=0 F S Z=$O(^PRC(420,"B",Z)) Q:Z="" D
.S Z1=Z_"-"_97
.S Z2=0 F S Z2=$O(^PRCF(421,"AJ",Z1,Z2)) Q:Z2="" D
..S F=$P($G(^PRCF(421,Z2,0)),"^",16) I F'="" K ^PRCF(421,"AG",F,Z2)
..S F1=$$ACC(Z2) Q:F1="" S ^PRCF(421,"AG",F1,Z2)="",$P(^PRCF(421,Z2,0),"^",16)=F1
.. W !,Z1," ",Z2," ",F1
..QUIT
.QUIT
QUIT
;
ACC(A) ;GET ACC CODE
N B,C,D,E,F,X
S X=^PRCF(421,A,0)
S B=$P(X,"-"),D=$P(X,"-",2),E=$P(+$P(X,"^",2)," ")
S C=$E($P(X,"^",23),2,3) S:C="" C=97 S C=+$$YEAR^PRC0C(C)
S F=$$ACC^PRC0C(B,E_"^"_D_"^"_C),F=B_"-"_D_"-"_$P(F,"^",11)_"-"_$P(F,"^",5)_"-"_$P(F,"^",2)
QUIT F
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSEM2 783 printed Dec 13, 2024@02:17:40 Page 2
PRCSEM2 ;WISC/KMB-RESET APPROPRIATION ENTRIES ; 7/23/96
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
+3 NEW Z,Z1,Z2,F,F1
+4 SET Z=0
FOR
SET Z=$ORDER(^PRC(420,"B",Z))
if Z=""
QUIT
Begin DoDot:1
+5 SET Z1=Z_"-"_97
+6 SET Z2=0
FOR
SET Z2=$ORDER(^PRCF(421,"AJ",Z1,Z2))
if Z2=""
QUIT
Begin DoDot:2
+7 SET F=$PIECE($GET(^PRCF(421,Z2,0)),"^",16)
IF F'=""
KILL ^PRCF(421,"AG",F,Z2)
+8 SET F1=$$ACC(Z2)
if F1=""
QUIT
SET ^PRCF(421,"AG",F1,Z2)=""
SET $PIECE(^PRCF(421,Z2,0),"^",16)=F1
+9 WRITE !,Z1," ",Z2," ",F1
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
ACC(A) ;GET ACC CODE
+1 NEW B,C,D,E,F,X
+2 SET X=^PRCF(421,A,0)
+3 SET B=$PIECE(X,"-")
SET D=$PIECE(X,"-",2)
SET E=$PIECE(+$PIECE(X,"^",2)," ")
+4 SET C=$EXTRACT($PIECE(X,"^",23),2,3)
if C=""
SET C=97
SET C=+$$YEAR^PRC0C(C)
+5 SET F=$$ACC^PRC0C(B,E_"^"_D_"^"_C)
SET F=B_"-"_D_"-"_$PIECE(F,"^",11)_"-"_$PIECE(F,"^",5)_"-"_$PIECE(F,"^",2)
+6 QUIT F
