PRCSEM2.m

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 ---PRCSEM2   783     printed  Apr 09, 2024@21:06:29                                                                                                                                                                                                      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