PRCOE3.m

PRCOE3 ;WISC/DJM-IFCAP SEGMENTS HE,MI,CO ;6/18/97  16:29

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

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

 ;

HE(VAR1,VAR2) ;PO HEADER INFORMATION SEGMENT

 ; uses PRCHPC variable to determine if document is a purchase card

 ; PRCHPC should not exist & should not be used in non-Purchase Card options

 ;

 ; VAR1 = string of up to 4 pieces -- (last 3 pieces are optional)

 ;        ('^' piece 1) ==>   ien to file 442 

 ;        ('^' piece 2) ==>   amendment flag (1 for PHM, 2 for PHA)

 ;        ('^' piece 3) ==>   amendment number

 ;        ('^' piece 4) ==>   442 ien of amended order if PO number

 ;                            was changed

 ;

 ; VAR2 is used to pass error conditions to the calling routine

 ;

 N A,A1,AFLG,ANO,B,DA,DD,NM,P,PHN,PM,PNM,PO,POD,PPM,RFQ,SC,MOP,X,Y

 S PO=$P(VAR1,"^",1)

 S A=$G(^PRC(442,PO,0))

 S A1=$G(^PRC(442,PO,1))

 I $G(^PRC(442,PO,12))="" S VAR2="NP12" Q  ; exit if no info in node 12

 ;

 S X=$P(A1,U,15)

 I X="" S VAR2="NPOD" Q  ; exit if no PO Date

 D JD^PRCFDLN ; puts julian date for X in Y

 S POD=$E(X,1,3)+1700_$E(Y,1,3)

 ;

 S X=$P(A,U,10)

 I X="" S VAR2="NDD" Q  ; exit if no delivery date

 D JD^PRCFDLN ; Puts julian date for X in Y

 S DD=$E(X,1,3)+1700_$E(Y,1,3)

 ;

 S AFLG=$P(VAR1,"^",2) I AFLG="" S AFLG=0

 S DA=PO

 I AFLG=2 S DA=$P(VAR1,"^",4) ; use old PO's ien if PO number was changed

 ;

 I 'AFLG S P=$P(A1,U,10)

 I AFLG D

 . S ANO=$P(VAR1,"^",3) ; amendment number

 . S P=$P(^PRC(442,DA,6,ANO,1),"^",1)

 I P="" S VAR2="NPPM" Q  ; exit if no PA/PPM (or Authorized buyer)

 ;

 S PHN=$P($G(^VA(200,P,.13)),"^",5)

 I '$G(PRCHPC) D  Q:PHN=""

 . I PHN="" S VAR2="NPHN" Q  ;exit if no commercial phone# for PA/PPM

 . S PHN=$P(PHN,U)

 . I PHN="" S VAR2="NPH" Q  ; exit (but when would there be an '^'???)

 ;

 I 'AFLG S PPM=$E("ES/"_$$DECODE^PRCHES5(DA),1,30)

 I AFLG S PPM=$E("ES/"_$$DECODE^PRCHES6(DA,ANO),1,30)

 I PPM="ES/" S VAR2="ESBD" Q  ; exit if no name found

 ;

 S PO=$P(VAR1,"^",1)

 S MOP=$P(A,U,2) ; method of processing

 S MOP=$S(MOP=1:"A",MOP=2:"B",MOP=3:"C",MOP=4:"D",MOP=7:"E",MOP=8:"F",MOP=9:"G",MOP=21:"H",MOP=22:"I",MOP=23:"J",MOP=24:"K",MOP=25:"L",MOP=26:"M",1:"")

 S:MOP="" MOP="A"

 ;

 S SC=$P(A1,U,7) ; source code

 S:SC>0 SC=$P($G(^PRCD(420.8,SC,0)),U)

 S RFQ=$P($G(^PRC(442,PO,21)),U,8)

 S PM=0

 S PM=$O(^PRC(442,PO,14,PM)) ; purchase method

 D:PM>0

 .  S PM=$P($G(^PRC(442,PO,14,PM,0)),U) Q:PM'>0

 .  S PM=$P($G(^PRC(442.4,PM,0)),U)

 .  Q

 ;

 S B="HE^^"_POD_"^"_SC_"^"_DD_"^^^"_PPM_"^"_PHN_"^"_PM_"^"_MOP_"^^0^^^^"_RFQ_"^1^|"

 S ^TMP($J,"STRING",1)=B

 Q

 ;

MI(VAR1,VAR2) ;MISCELLANEOUS INFORMATION SEGMENT

 N B,F1,F2,I2,ITEM,M0,M1,M12,M23,PR

 S M0=$G(^PRC(442,VAR1,0))

 S M1=$G(^PRC(442,VAR1,1))

 S M12=$G(^PRC(442,VAR1,12))

 S M23=$G(^PRC(442,VAR1,23))

 S B="MI^^"_$P(M12,U,7)_"^" ; FIELDS 1, 2, 3

 I $P(M23,U,11)="P" S F1="" G MI1

 S F1=$P(M1,U,7)

 S:F1="" VAR2="NSC"

 Q:F1=""

 S F1=$S(F1=9:"B","2,3,5,8"[F1:"P",1:"D")

MI1 S B=B_F1_"^^^" ; FIELDS 4, 5, 6

 S PR=$P(M1,U,8)

 I $P(M0,U,19)=2,PR="" S PR="N/A"

 S:PR="" VAR2="NOPR"

 Q:PR=""

 S B=B_PR_"^^^^|" ; FIELDS 7, 8, 9, 10, 11

 S ^TMP($J,"STRING",5)=B

 Q

 ;

CO(VAR1,VAR2,TOTAL) ;COMMENT INFORMATION SEGMENT

 N B,TOSH

 S TOSH=$P($G(^PRC(442,VAR1,12)),U,14)

 Q:TOSH=""

 S TOSH=$E($P(^PRC(443.4,TOSH,0),U,3),1,59)

 S B="CO^1^"_TOSH_"^|"

 S ^TMP($J,"STRING",TOTAL)=B

 S TOTAL=TOTAL+1

 S B=^TMP($J,"STRING",1)

 S $P(B,U,13)=$P(B,U,13)+1

 S ^TMP($J,"STRING",1)=B

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCOE3   3531     printed  Feb 18, 2025@23:38:07                                                                                                                                                                                                      Page 2

PRCOE3    ;WISC/DJM-IFCAP SEGMENTS HE,MI,CO ;6/18/97  16:29

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

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

 +2       ;

HE(VAR1,VAR2) ;PO HEADER INFORMATION SEGMENT

 +1       ; uses PRCHPC variable to determine if document is a purchase card

 +2       ; PRCHPC should not exist & should not be used in non-Purchase Card options

 +3       ;

 +4       ; VAR1 = string of up to 4 pieces -- (last 3 pieces are optional)

 +5       ;        ('^' piece 1) ==>   ien to file 442 

 +6       ;        ('^' piece 2) ==>   amendment flag (1 for PHM, 2 for PHA)

 +7       ;        ('^' piece 3) ==>   amendment number

 +8       ;        ('^' piece 4) ==>   442 ien of amended order if PO number

 +9       ;                            was changed

 +10      ;

 +11      ; VAR2 is used to pass error conditions to the calling routine

 +12      ;

 +13       NEW A,A1,AFLG,ANO,B,DA,DD,NM,P,PHN,PM,PNM,PO,POD,PPM,RFQ,SC,MOP,X,Y

 +14       SET PO=$PIECE(VAR1,"^",1)

 +15       SET A=$GET(^PRC(442,PO,0))

 +16       SET A1=$GET(^PRC(442,PO,1))

 +17      ; exit if no info in node 12

           IF $GET(^PRC(442,PO,12))=""

               SET VAR2="NP12"

               QUIT 

 +18      ;

 +19       SET X=$PIECE(A1,U,15)

 +20      ; exit if no PO Date

           IF X=""

               SET VAR2="NPOD"

               QUIT 

 +21      ; puts julian date for X in Y

           DO JD^PRCFDLN

 +22       SET POD=$EXTRACT(X,1,3)+1700_$EXTRACT(Y,1,3)

 +23      ;

 +24       SET X=$PIECE(A,U,10)

 +25      ; exit if no delivery date

           IF X=""

               SET VAR2="NDD"

               QUIT 

 +26      ; Puts julian date for X in Y

           DO JD^PRCFDLN

 +27       SET DD=$EXTRACT(X,1,3)+1700_$EXTRACT(Y,1,3)

 +28      ;

 +29       SET AFLG=$PIECE(VAR1,"^",2)

           IF AFLG=""

               SET AFLG=0

 +30       SET DA=PO

 +31      ; use old PO's ien if PO number was changed

           IF AFLG=2

               SET DA=$PIECE(VAR1,"^",4)

 +32      ;

 +33       IF 'AFLG

               SET P=$PIECE(A1,U,10)

 +34       IF AFLG

               Begin DoDot:1

 +35      ; amendment number

                   SET ANO=$PIECE(VAR1,"^",3)

 +36               SET P=$PIECE(^PRC(442,DA,6,ANO,1),"^",1)

               End DoDot:1

 +37      ; exit if no PA/PPM (or Authorized buyer)

           IF P=""

               SET VAR2="NPPM"

               QUIT 

 +38      ;

 +39       SET PHN=$PIECE($GET(^VA(200,P,.13)),"^",5)

 +40       IF '$GET(PRCHPC)

               Begin DoDot:1

 +41      ;exit if no commercial phone# for PA/PPM

                   IF PHN=""

                       SET VAR2="NPHN"

                       QUIT 

 +42               SET PHN=$PIECE(PHN,U)

 +43      ; exit (but when would there be an '^'???)

                   IF PHN=""

                       SET VAR2="NPH"

                       QUIT 

               End DoDot:1

               if PHN=""

                   QUIT 

 +44      ;

 +45       IF 'AFLG

               SET PPM=$EXTRACT("ES/"_$$DECODE^PRCHES5(DA),1,30)

 +46       IF AFLG

               SET PPM=$EXTRACT("ES/"_$$DECODE^PRCHES6(DA,ANO),1,30)

 +47      ; exit if no name found

           IF PPM="ES/"

               SET VAR2="ESBD"

               QUIT 

 +48      ;

 +49       SET PO=$PIECE(VAR1,"^",1)

 +50      ; method of processing

           SET MOP=$PIECE(A,U,2)

 +51       SET MOP=$SELECT(MOP=1:"A",MOP=2:"B",MOP=3:"C",MOP=4:"D",MOP=7:"E",MOP=8:"F",MOP=9:"G",MOP=21:"H",MOP=22:"I",MOP=23:"J",MOP=24:"K",MOP=25:"L",MOP=26:"M",1:"")

 +52       if MOP=""

               SET MOP="A"

 +53      ;

 +54      ; source code

           SET SC=$PIECE(A1,U,7)

 +55       if SC>0

               SET SC=$PIECE($GET(^PRCD(420.8,SC,0)),U)

 +56       SET RFQ=$PIECE($GET(^PRC(442,PO,21)),U,8)

 +57       SET PM=0

 +58      ; purchase method

           SET PM=$ORDER(^PRC(442,PO,14,PM))

 +59       if PM>0

               Begin DoDot:1

 +60               SET PM=$PIECE($GET(^PRC(442,PO,14,PM,0)),U)

                   if PM'>0

                       QUIT 

 +61               SET PM=$PIECE($GET(^PRC(442.4,PM,0)),U)

 +62               QUIT 

               End DoDot:1

 +63      ;

 +64       SET B="HE^^"_POD_"^"_SC_"^"_DD_"^^^"_PPM_"^"_PHN_"^"_PM_"^"_MOP_"^^0^^^^"_RFQ_"^1^|"

 +65       SET ^TMP($JOB,"STRING",1)=B

 +66       QUIT 

 +67      ;

MI(VAR1,VAR2) ;MISCELLANEOUS INFORMATION SEGMENT

 +1        NEW B,F1,F2,I2,ITEM,M0,M1,M12,M23,PR

 +2        SET M0=$GET(^PRC(442,VAR1,0))

 +3        SET M1=$GET(^PRC(442,VAR1,1))

 +4        SET M12=$GET(^PRC(442,VAR1,12))

 +5        SET M23=$GET(^PRC(442,VAR1,23))

 +6       ; FIELDS 1, 2, 3

           SET B="MI^^"_$PIECE(M12,U,7)_"^"

 +7        IF $PIECE(M23,U,11)="P"

               SET F1=""

               GOTO MI1

 +8        SET F1=$PIECE(M1,U,7)

 +9        if F1=""

               SET VAR2="NSC"

 +10       if F1=""

               QUIT 

 +11       SET F1=$SELECT(F1=9:"B","2,3,5,8"[F1:"P",1:"D")

MI1       ; FIELDS 4, 5, 6

           SET B=B_F1_"^^^"

 +1        SET PR=$PIECE(M1,U,8)

 +2        IF $PIECE(M0,U,19)=2

               IF PR=""

                   SET PR="N/A"

 +3        if PR=""

               SET VAR2="NOPR"

 +4        if PR=""

               QUIT 

 +5       ; FIELDS 7, 8, 9, 10, 11

           SET B=B_PR_"^^^^|"

 +6        SET ^TMP($JOB,"STRING",5)=B

 +7        QUIT 

 +8       ;

CO(VAR1,VAR2,TOTAL) ;COMMENT INFORMATION SEGMENT

 +1        NEW B,TOSH

 +2        SET TOSH=$PIECE($GET(^PRC(442,VAR1,12)),U,14)

 +3        if TOSH=""

               QUIT 

 +4        SET TOSH=$EXTRACT($PIECE(^PRC(443.4,TOSH,0),U,3),1,59)

 +5        SET B="CO^1^"_TOSH_"^|"

 +6        SET ^TMP($JOB,"STRING",TOTAL)=B

 +7        SET TOTAL=TOTAL+1

 +8        SET B=^TMP($JOB,"STRING",1)

 +9        SET $PIECE(B,U,13)=$PIECE(B,U,13)+1

 +10       SET ^TMP($JOB,"STRING",1)=B

 +11       QUIT