- 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 Feb 18, 2025@23:44:03 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