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 ---[H[J[2J[HPRCOE3 3531 printed Dec 13, 2024@02:11:44 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
