PRCX1P1.m

PRCX1P1 ;WISC/PLT-FIX FILE 442 BBFY AND APPROPRIATION ; 10/17/95  3:10 PM

V ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 ;QUIT  ; invalid entry

 ;

EN ;start fix file 410/442

 N PRCRI,PRCSITE,PRCYEAR,PRCYE,PRCQTR,PRCFCP,PRCDATE

 N PRCA,PRCB,PRCC

 S PRCYEAR=1996,PRCYE=96,PRCDATE=2950630

 S PRCRI(420)=0 F  S PRCRI(420)=$O(^PRC(420,PRCRI(420))) QUIT:'PRCRI(420)  S PRCC="" D  QUIT:PRCC=-1

 . D EN^DDIOL("STATION # "_PRCRI(420)_" starts:")

 . S PRCSITE=PRCRI(420)

 . D @("AUTO"_PRCDD)

 . QUIT

 QUIT

 ;

 ;

AUTO410 ;auto select file 410 for 1996

 S PRCA=PRCSITE_"-"_PRCYE

 S PRCB=PRCA F  S PRCB=$O(^PRCS(410,"B",PRCB)) QUIT:PRCA-PRCB  S PRCRI(410)=$O(^(PRCB,"")) D:PRCRI(410)

 . N A,B,C,D,PRC,PRCX,PRCACC,PRCBBFY

 . S PRC=$G(^PRCS(410,PRCRI(410),3)),PRCX=$G(^(0))

 . S A=$$BBFY^PRCSUT($P(PRCX,"-"),$P(PRCX,"-",2),$P(PRCX,"-",4),1)

 . S PRCACC=$$ACC^PRC0C($P(PRCX,"-"),$P(PRCX,"-",4)_"^"_$P(PRCX,"-",2)_"^"_A)

 . S PRCBBFY=$P($$DATE^PRC0C(PRC("BBFY"),"E"),"^",7)

 . S:$P(PRC,"^",11)'=PRCBBFY $P(PRC,"^",11)=PRCBBFY

 . S:$P(PRC,"^",2)'=$P(PRCACC,"^",11) $P(PRC,"^",2)=$P(PRCACC,"^",11)

 . S:$P(PRC,"^",12)'=$P(PRCACC,"^",3) $P(PRC,"^",12)=$P(PRCACC,"^",3)

 . ;W !,"***",$P(PRCX,"^"),!,"***",$G(^PRCS(410,PRCRI(410),3)),!,"***",PRC

 . I $G(^PRCS(410,PRCRI(410),3))'=PRC W !,$P(PRCX,"^"),!,"OLD: ",$G(^(3)),!,"NEW: ",PRC S ^(3)=PRC

 . QUIT

 QUIT

 ;

AUTO442 ;auto select file 442 for 1996

 S PRCA=PRCDATE

 S PRCB=PRCA F  S PRCB=$O(^PRC(442,"AB",PRCB)) QUIT:'PRCB  D  QUIT:PRCC=-1

 . S PRCRI(442)=0 F  S PRCRI(442)=$O(^PRC(442,"AB",PRCB,PRCRI(442))) QUIT:'PRCRI(442)  D:^PRC(442,PRCRI(442),0)-PRCSITE=0 442 QUIT:PRCC=-1

 . QUIT

 QUIT

 ;

410 ;display/edit substation

 W ! D  ;display

 . N DIC,DA,DR,WIQ

 . S DIC="^PRCS(410,",DA=PRCRI(410),DR="0;3;4;RM" D EN^DIQ

 . QUIT

 S PRC("SITE")=+^PRCS(410,PRCRI(410),0)

 D EDIT^PRC0B(.X,"410;;"_PRCRI(410),"28.5;28;28.1","")

 S PRCC=X

 D EN^DDIOL(" "),EN^DDIOL($TR($J("",78)," ","-"))

 QUIT

 ;

442 ;display/edit substation

 W ! D  ;display

 . N DIC,DA,DR,WIQ

 . S DIC="^PRC(442,",DA=PRCRI(442),DR="0;12;4" D EN^DIQ

 . W "    PURCHASE ORDER DATE: ",$E(PRCB,4,5),"/",$E(PRCB,6,7),"/",$E(PRCB,2,3)

 . QUIT

 S PRC("SITE")=+^PRC(442,PRCRI(442),0)

 D EDIT^PRC0B(.X,"442;;"_PRCRI(442),"26;1.4","")

 S PRCC=X

 D EN^DDIOL(" "),EN^DDIOL($TR($J("",78)," ","-"))

 QUIT

 ;

EN1 D @("MAN"_PRCDD)

 QUIT

 ;

 ;

 ;

 ;

MAN410 ;manual select 410 for 1996

 S X("S")="I $P($G(^(0)),""-"",2)>95"

 D LOOKUP^PRC0B(.X,.Y,"410","AEMOQS","Select 2237/1358 Request: ")

 I X=""!(X["^") QUIT

 I Y>0 S PRCRI(410)=+Y D 410

 G MAN410

 QUIT

 ;

MAN442 ;MANUAL SELECT 442 for 1996

 S X("S")="I $P($G(^(1)),""^"",15)>2950630"

 D LOOKUP^PRC0B(.X,.Y,"442","AEMOQS","Select Purchase Order: ")

 I X=""!(X["^") QUIT

 I Y>0 S PRCRI(442)=+Y,PRCB=$P($G(^PRC(442,PRCRI(442),1)),"^",15) D 442

 G MAN442

 ;

GECS ;rebuild rejected mo/so doc for obligation after 9/30/95

 N PRCRI,PRCA,PRCB,PRCA

 S PRCRI(2100.1)=0 F  S PRCRI(2100.1)=$O(^GECS(2100.1,"AS","R",PRCRI(2100.1))) QUIT:'PRCRI(2100.1)  D GECS1:$G(^GECS(2100.1,PRCRI(2100.1),0))?1"MO".E!($G(^(0))?1"SO".E)

 W !,"ALL DONE!    ALL DONE!"

 QUIT

 ;

GECS1 ;rebuild mo/so record

 N PRCA,PRCB,PRC

 N A,B,C

 S A=^GECS(2100.1,PRCRI(2100.1),0),B=$G(^(26))

 QUIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCX1P1   3331     printed  Mar 13, 2025@21:25:13                                                                                                                                                                                                     Page 2

PRCX1P1   ;WISC/PLT-FIX FILE 442 BBFY AND APPROPRIATION ; 10/17/95  3:10 PM

V         ;;5.1;IFCAP;;Oct 20, 2000

 +1       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +2       ;QUIT  ; invalid entry

 +3       ;

EN        ;start fix file 410/442

 +1        NEW PRCRI,PRCSITE,PRCYEAR,PRCYE,PRCQTR,PRCFCP,PRCDATE

 +2        NEW PRCA,PRCB,PRCC

 +3        SET PRCYEAR=1996

           SET PRCYE=96

           SET PRCDATE=2950630

 +4        SET PRCRI(420)=0

           FOR 

               SET PRCRI(420)=$ORDER(^PRC(420,PRCRI(420)))

               if 'PRCRI(420)

                   QUIT 

               SET PRCC=""

               Begin DoDot:1

 +5                DO EN^DDIOL("STATION # "_PRCRI(420)_" starts:")

 +6                SET PRCSITE=PRCRI(420)

 +7                DO @("AUTO"_PRCDD)

 +8                QUIT 

               End DoDot:1

               if PRCC=-1

                   QUIT 

 +9        QUIT 

 +10      ;

 +11      ;

AUTO410   ;auto select file 410 for 1996

 +1        SET PRCA=PRCSITE_"-"_PRCYE

 +2        SET PRCB=PRCA

           FOR 

               SET PRCB=$ORDER(^PRCS(410,"B",PRCB))

               if PRCA-PRCB

                   QUIT 

               SET PRCRI(410)=$ORDER(^(PRCB,""))

               if PRCRI(410)

                   Begin DoDot:1

 +3                    NEW A,B,C,D,PRC,PRCX,PRCACC,PRCBBFY

 +4                    SET PRC=$GET(^PRCS(410,PRCRI(410),3))

                       SET PRCX=$GET(^(0))

 +5                    SET A=$$BBFY^PRCSUT($PIECE(PRCX,"-"),$PIECE(PRCX,"-",2),$PIECE(PRCX,"-",4),1)

 +6                    SET PRCACC=$$ACC^PRC0C($PIECE(PRCX,"-"),$PIECE(PRCX,"-",4)_"^"_$PIECE(PRCX,"-",2)_"^"_A)

 +7                    SET PRCBBFY=$PIECE($$DATE^PRC0C(PRC("BBFY"),"E"),"^",7)

 +8                    if $PIECE(PRC,"^",11)'=PRCBBFY

                           SET $PIECE(PRC,"^",11)=PRCBBFY

 +9                    if $PIECE(PRC,"^",2)'=$PIECE(PRCACC,"^",11)

                           SET $PIECE(PRC,"^",2)=$PIECE(PRCACC,"^",11)

 +10                   if $PIECE(PRC,"^",12)'=$PIECE(PRCACC,"^",3)

                           SET $PIECE(PRC,"^",12)=$PIECE(PRCACC,"^",3)

 +11      ;W !,"***",$P(PRCX,"^"),!,"***",$G(^PRCS(410,PRCRI(410),3)),!,"***",PRC

 +12                   IF $GET(^PRCS(410,PRCRI(410),3))'=PRC

                           WRITE !,$PIECE(PRCX,"^"),!,"OLD: ",$GET(^(3)),!,"NEW: ",PRC

                           SET ^(3)=PRC

 +13                   QUIT 

                   End DoDot:1

 +14       QUIT 

 +15      ;

AUTO442   ;auto select file 442 for 1996

 +1        SET PRCA=PRCDATE

 +2        SET PRCB=PRCA

           FOR 

               SET PRCB=$ORDER(^PRC(442,"AB",PRCB))

               if 'PRCB

                   QUIT 

               Begin DoDot:1

 +3                SET PRCRI(442)=0

                   FOR 

                       SET PRCRI(442)=$ORDER(^PRC(442,"AB",PRCB,PRCRI(442)))

                       if 'PRCRI(442)

                           QUIT 

                       if ^PRC(442,PRCRI(442),0)-PRCSITE=0

                           DO 442

                       if PRCC=-1

                           QUIT 

 +4                QUIT 

               End DoDot:1

               if PRCC=-1

                   QUIT 

 +5        QUIT 

 +6       ;

410       ;display/edit substation

 +1       ;display

           WRITE !

           Begin DoDot:1

 +2            NEW DIC,DA,DR,WIQ

 +3            SET DIC="^PRCS(410,"

               SET DA=PRCRI(410)

               SET DR="0;3;4;RM"

               DO EN^DIQ

 +4            QUIT 

           End DoDot:1

 +5        SET PRC("SITE")=+^PRCS(410,PRCRI(410),0)

 +6        DO EDIT^PRC0B(.X,"410;;"_PRCRI(410),"28.5;28;28.1","")

 +7        SET PRCC=X

 +8        DO EN^DDIOL(" ")

           DO EN^DDIOL($TRANSLATE($JUSTIFY("",78)," ","-"))

 +9        QUIT 

 +10      ;

442       ;display/edit substation

 +1       ;display

           WRITE !

           Begin DoDot:1

 +2            NEW DIC,DA,DR,WIQ

 +3            SET DIC="^PRC(442,"

               SET DA=PRCRI(442)

               SET DR="0;12;4"

               DO EN^DIQ

 +4            WRITE "    PURCHASE ORDER DATE: ",$EXTRACT(PRCB,4,5),"/",$EXTRACT(PRCB,6,7),"/",$EXTRACT(PRCB,2,3)

 +5            QUIT 

           End DoDot:1

 +6        SET PRC("SITE")=+^PRC(442,PRCRI(442),0)

 +7        DO EDIT^PRC0B(.X,"442;;"_PRCRI(442),"26;1.4","")

 +8        SET PRCC=X

 +9        DO EN^DDIOL(" ")

           DO EN^DDIOL($TRANSLATE($JUSTIFY("",78)," ","-"))

 +10       QUIT 

 +11      ;

EN1        DO @("MAN"_PRCDD)

 +1        QUIT 

 +2       ;

 +3       ;

 +4       ;

 +5       ;

MAN410    ;manual select 410 for 1996

 +1        SET X("S")="I $P($G(^(0)),""-"",2)>95"

 +2        DO LOOKUP^PRC0B(.X,.Y,"410","AEMOQS","Select 2237/1358 Request: ")

 +3        IF X=""!(X["^")

               QUIT 

 +4        IF Y>0

               SET PRCRI(410)=+Y

               DO 410

 +5        GOTO MAN410

 +6        QUIT 

 +7       ;

MAN442    ;MANUAL SELECT 442 for 1996

 +1        SET X("S")="I $P($G(^(1)),""^"",15)>2950630"

 +2        DO LOOKUP^PRC0B(.X,.Y,"442","AEMOQS","Select Purchase Order: ")

 +3        IF X=""!(X["^")

               QUIT 

 +4        IF Y>0

               SET PRCRI(442)=+Y

               SET PRCB=$PIECE($GET(^PRC(442,PRCRI(442),1)),"^",15)

               DO 442

 +5        GOTO MAN442

 +6       ;

GECS      ;rebuild rejected mo/so doc for obligation after 9/30/95

 +1        NEW PRCRI,PRCA,PRCB,PRCA

 +2        SET PRCRI(2100.1)=0

           FOR 

               SET PRCRI(2100.1)=$ORDER(^GECS(2100.1,"AS","R",PRCRI(2100.1)))

               if 'PRCRI(2100.1)

                   QUIT 

               if $GET(^GECS(2100.1,PRCRI(2100.1),0))?1"MO".E!($GET(^(0))?1"SO".E)

                   DO GECS1

 +3        WRITE !,"ALL DONE!    ALL DONE!"

 +4        QUIT 

 +5       ;

GECS1     ;rebuild mo/so record

 +1        NEW PRCA,PRCB,PRC

 +2        NEW A,B,C

 +3        SET A=^GECS(2100.1,PRCRI(2100.1),0)

           SET B=$GET(^(26))

 +4        QUIT