- PRCOE1 ;WISC/DJM/BGJ-IFCAP SEGMENTS ISM,BI,VE,ST ;4/20/98 21:50
- V ;;5.1;IFCAP;**48**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ISM(A) ;STANDARD CONTROL STRING - REQUIRED AT BEGINNING OF EACH TRANSACTION
- N %,B,JD,TIME,X,Y
- S B="ISM^"_+$P(A,U)_"^200^PHA^" D NOW^%DTC S X=$P(%,".") D JD^PRCFDLN S JD=$E(X,1,3)+1700_$E(Y,1,3),TIME=$P(%,".",2)_"000000",TIME=$E(TIME,1,6),B=B_JD_"^"_TIME_"^"
- S B=B_$P($P(A,U),"-")_$P($P(A,U),"-",2)_" "_"^"_"001"_"^"_"001"_"^"_"001"_"^|",PRCFA("STRING")=B Q
- BI(A,VAR1,VAR2) ;BILL TO INFORMATION SEGMENT
- N A12,A23,B,BTS,IA,INV,SITE,ST
- S (A23,SITE)=$G(^PRC(442,VAR1,23)) S:SITE]"" SITE=$P(SITE,U,7) S SITE=$S($G(SITE)]"":SITE,1:+$P(A,U))
- I $P(A23,U,11)="P" S B="BI^^^^^^^^^^|" G BI1
- S B=""
- I $P(A,U,2)=25 D G BI1
- . N PRCA,PRCB,PRCC
- . S PRCA=$P(A23,U,8) Q:PRCA'>0
- . S PRCB=$G(^PRC(440.5,PRCA,0)) Q:PRCB=""
- . S PRCC=$P(PRCB,U,8) S:PRCC>0 PRCC=$P($G(^VA(200,PRCC,0)),U)
- . S B="BI^^"_PRCC_"^"_$$ENCODE^PRCOCRYP($P(PRCB,U),VAR1)
- . S PRCC=$P($G(^PRC(440.5,PRCA,2)),U,4),PRCB=""
- . I PRCC'="" D
- . . S PRCB=$E(PRCC,4,5) S:$E(PRCC,6,7)>0 PRCB=PRCB_"/"_$E(PRCC,6,7)
- . . S PRCB=PRCB_"/"_$E(PRCC,2,3)
- . S B=B_"^"_$$ENCODE^PRCOCRYP(PRCB,VAR1)_"^"_"CC"_VAR1_"^^^^^|"
- S A12=$G(^PRC(442,VAR1,12)) S:A12="" VAR2="NP12" Q:A12=""
- S IA=$P(A12,U,6)
- S:IA="" VAR2="NPIA" Q:IA="" S INV=$G(^PRC(411,SITE,4,IA,0)) S:INV="" VAR2="NMIL" Q:INV=""
- S VAR2="" S:$P(INV,U,5)="" VAR2="NMIC" Q:VAR2]"" S:$P(INV,U,6)="" VAR2="NMIS" Q:VAR2]"" S:$P(INV,U,7)="" VAR2="NMIZ" Q:VAR2]""
- S B="BI^",BTS=$P(INV,U,8),B=B_$S(BTS]"":BTS,1:"")
- S B=B_"^"_$P(INV,U)_"^"_$P(INV,U,2)_"^"_$P(INV,U,3)_"^"_$P(INV,U,4)_"^^"_$P(INV,U,5)_"^"
- S ST=$G(^DIC(5,$P(INV,U,6),0)) S:ST="" VAR2="NST0" Q:VAR2]"" S:$P(ST,U,2)="" VAR2="NSTA" Q:VAR2]"" S B=B_$E($P(ST,U,2),1,2)_"^"_$P($P(INV,U,7),"-")_$P($P(INV,U,7),"-",2)_"^|"
- BI1 S ^TMP($J,"STRING",2)=B Q
- ;
- VE(A1,VAR2) ;VENDOR INFORMATION SEGMENT
- N B,EDI,ST,V,V3,VEN,VID
- S VEN=$P(A1,U)
- S V3=$G(^PRC(440,VEN,3))
- S V=$G(^PRC(440,VEN,0))
- S:V="" VAR2="NV0"
- Q:V=""
- S:$P(V,U,7)'>0 VAR2="NSTP"
- Q:VAR2]""
- S B="VE^" ; FIELD 1
- S EDI=$P(V3,U,2)
- S VID=$P(V3,U,3)
- I EDI="Y",VID="" S VAR2="NVID"
- Q:VAR2]""
- S B=B_$S(VID]"":VID,1:"") ; FIELD 2
- S B=B_"^"_$P(V,U)_"^"_$P(V,U,2)_"^"_$P(V,U,3)_"^"_$P(V,U,4)_"^"_$P(V,U,6)_"^" ; FIELDS 3, 4, 5, 6, 7
- S ST=$G(^DIC(5,$P(V,U,7),0))
- S:ST="" VAR2="NST0"
- Q:ST=""
- S:$P(ST,U,2)="" VAR2="NSTA"
- Q:VAR2]""
- S B=B_$E($P(ST,U,2),1,2)_"^"_$P($P(V,U,8),"-")_$P($P(V,U,8),"-",2)_"^"_$P(V,U,10)_"^^^^^^^^^^|" ; FIELDS 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20
- VE1 S ^TMP($J,"STRING",3)=B
- Q
- ;
- ST(A,A1,VAR1,VAR2) ;SHIP TO INFORMATION SEGMENT
- N B,DDP,DDP0,EDI,FT,FT0,MP,NM,RL,SP0,ST,STS,VEN,SITE1
- S MP=$P(A,U,2),DDP=$P(A1,U,12),B="ST^" G:MP=4&(DDP]"") STD
- S VEN=$P(A1,U),V3=$G(^PRC(440,VEN,3)),EDI=$P(V3,U,2)
- S SITE1=$G(^PRC(442,VAR1,23)) S:SITE1]"" SITE=$P(SITE1,U,7) S SITE=$S($G(SITE)]"":SITE,1:+$P(A,U))
- S:SITE="" VAR2="NSIT" Q:SITE=""
- S ST=$P(A1,U,3)
- I $P(SITE1,U,11)="P",ST="" S B=B_"^^^^^^^^^|" G ST1
- S:ST="" VAR2="NSTL" Q:ST="" S RL=$G(^PRC(411,SITE,1,ST,0)) S:RL="" VAR2="NRL" Q:RL="" S:$P(RL,U,6)'>0 VAR2="NSTT" Q:VAR2]""
- S STS=$P(RL,U,9) I EDI="Y",STS="",SITE'=101 S VAR2="NSTS" Q
- S B=B_$S(STS]"":STS,1:""),SP0=$G(^PRC(411,SITE,0)) S:SP0="" VAR2="NSP0^"_SITE Q:SP0="" S FT=$P(SP0,U,7) S:FT="" VAR2="NFT^"_SITE Q:FT="" S FT0=$G(^PRC(411.2,FT,0)) S:FT0="" VAR2="NFT0^"_SITE Q:FT0=""
- S B=B_"^"_$S($P(FT0,U,2)]"":$P(FT0,U,2),1:"V.A. *NO FACILITY TYPE*")_"^"
- S B=B_$E($P(RL,U,1),1,17)_" "_$P($P(A,U),"-",2)_"^"_$P(RL,U,2)_"^"_$P(RL,U,3)_"^"_$P(RL,U,4)_"^"_$P(RL,U,5)_"^"
- S ST=$G(^DIC(5,$P(RL,U,6),0)) S:ST="" VAR2="NST0" Q:ST="" S:$P(ST,U,2)="" VAR2="NSTA" Q:VAR2]""
- S B=B_$E($P(ST,U,2),1,2)_"^"_$P($P(RL,U,7),"-")_$P($P(RL,U,7),"-",2)_"^|" G ST1
- STD S NM=$G(^DPT(DDP,0)) S:NM="" VAR2="NOPT" Q:NM="" S NM=$E($P(NM,U),1,30),NM=$P(NM,",",2)_" "_$P(NM,",")
- S DDP0=$G(^PRC(440.2,DDP,0)) S:DDP0="" VAR2="NDP0" Q:DDP0="" S B=B_"^"_NM_"^"_$P(DDP0,U,2)_"^"_$P(DDP0,U,3)_"^"_$P(DDP0,U,4)_"^^" S:$P(DDP0,U,6)'>0 VAR2="NSTDP" Q:VAR2]""
- S ST=$G(^DIC(5,$P(DDP0,U,6),0)) S:ST="" VAR2="NST0" Q:ST="" S:$P(ST,U,2)="" VAR2="NSTA" Q:VAR2]"" S B=B_$P(DDP0,U,5)_"^"_$E($P(ST,U,2),1,2)_"^"_$P($P(DDP0,U,7),"-")_$P($P(DDP0,U,7),"-",2)_"^|"
- ST1 S ^TMP($J,"STRING",4)=B Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCOE1 4377 printed Feb 18, 2025@23:38:05 Page 2
- PRCOE1 ;WISC/DJM/BGJ-IFCAP SEGMENTS ISM,BI,VE,ST ;4/20/98 21:50
- V ;;5.1;IFCAP;**48**;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;
- ISM(A) ;STANDARD CONTROL STRING - REQUIRED AT BEGINNING OF EACH TRANSACTION
- +1 NEW %,B,JD,TIME,X,Y
- +2 SET B="ISM^"_+$PIECE(A,U)_"^200^PHA^"
- DO NOW^%DTC
- SET X=$PIECE(%,".")
- DO JD^PRCFDLN
- SET JD=$EXTRACT(X,1,3)+1700_$EXTRACT(Y,1,3)
- SET TIME=$PIECE(%,".",2)_"000000"
- SET TIME=$EXTRACT(TIME,1,6)
- SET B=B_JD_"^"_TIME_"^"
- +3 SET B=B_$PIECE($PIECE(A,U),"-")_$PIECE($PIECE(A,U),"-",2)_" "_"^"_"001"_"^"_"001"_"^"_"001"_"^|"
- SET PRCFA("STRING")=B
- QUIT
- BI(A,VAR1,VAR2) ;BILL TO INFORMATION SEGMENT
- +1 NEW A12,A23,B,BTS,IA,INV,SITE,ST
- +2 SET (A23,SITE)=$GET(^PRC(442,VAR1,23))
- if SITE]""
- SET SITE=$PIECE(SITE,U,7)
- SET SITE=$SELECT($GET(SITE)]"":SITE,1:+$PIECE(A,U))
- +3 IF $PIECE(A23,U,11)="P"
- SET B="BI^^^^^^^^^^|"
- GOTO BI1
- +4 SET B=""
- +5 IF $PIECE(A,U,2)=25
- Begin DoDot:1
- +6 NEW PRCA,PRCB,PRCC
- +7 SET PRCA=$PIECE(A23,U,8)
- if PRCA'>0
- QUIT
- +8 SET PRCB=$GET(^PRC(440.5,PRCA,0))
- if PRCB=""
- QUIT
- +9 SET PRCC=$PIECE(PRCB,U,8)
- if PRCC>0
- SET PRCC=$PIECE($GET(^VA(200,PRCC,0)),U)
- +10 SET B="BI^^"_PRCC_"^"_$$ENCODE^PRCOCRYP($PIECE(PRCB,U),VAR1)
- +11 SET PRCC=$PIECE($GET(^PRC(440.5,PRCA,2)),U,4)
- SET PRCB=""
- +12 IF PRCC'=""
- Begin DoDot:2
- +13 SET PRCB=$EXTRACT(PRCC,4,5)
- if $EXTRACT(PRCC,6,7)>0
- SET PRCB=PRCB_"/"_$EXTRACT(PRCC,6,7)
- +14 SET PRCB=PRCB_"/"_$EXTRACT(PRCC,2,3)
- End DoDot:2
- +15 SET B=B_"^"_$$ENCODE^PRCOCRYP(PRCB,VAR1)_"^"_"CC"_VAR1_"^^^^^|"
- End DoDot:1
- GOTO BI1
- +16 SET A12=$GET(^PRC(442,VAR1,12))
- if A12=""
- SET VAR2="NP12"
- if A12=""
- QUIT
- +17 SET IA=$PIECE(A12,U,6)
- +18 if IA=""
- SET VAR2="NPIA"
- if IA=""
- QUIT
- SET INV=$GET(^PRC(411,SITE,4,IA,0))
- if INV=""
- SET VAR2="NMIL"
- if INV=""
- QUIT
- +19 SET VAR2=""
- if $PIECE(INV,U,5)=""
- SET VAR2="NMIC"
- if VAR2]""
- QUIT
- if $PIECE(INV,U,6)=""
- SET VAR2="NMIS"
- if VAR2]""
- QUIT
- if $PIECE(INV,U,7)=""
- SET VAR2="NMIZ"
- if VAR2]""
- QUIT
- +20 SET B="BI^"
- SET BTS=$PIECE(INV,U,8)
- SET B=B_$SELECT(BTS]"":BTS,1:"")
- +21 SET B=B_"^"_$PIECE(INV,U)_"^"_$PIECE(INV,U,2)_"^"_$PIECE(INV,U,3)_"^"_$PIECE(INV,U,4)_"^^"_$PIECE(INV,U,5)_"^"
- +22 SET ST=$GET(^DIC(5,$PIECE(INV,U,6),0))
- if ST=""
- SET VAR2="NST0"
- if VAR2]""
- QUIT
- if $PIECE(ST,U,2)=""
- SET VAR2="NSTA"
- if VAR2]""
- QUIT
- SET B=B_$EXTRACT($PIECE(ST,U,2),1,2)_"^"_$PIECE($PIECE(INV,U,7),"-")_$PIECE($PIECE(INV,U,7),"-",2)_"^|"
- BI1 SET ^TMP($JOB,"STRING",2)=B
- QUIT
- +1 ;
- VE(A1,VAR2) ;VENDOR INFORMATION SEGMENT
- +1 NEW B,EDI,ST,V,V3,VEN,VID
- +2 SET VEN=$PIECE(A1,U)
- +3 SET V3=$GET(^PRC(440,VEN,3))
- +4 SET V=$GET(^PRC(440,VEN,0))
- +5 if V=""
- SET VAR2="NV0"
- +6 if V=""
- QUIT
- +7 if $PIECE(V,U,7)'>0
- SET VAR2="NSTP"
- +8 if VAR2]""
- QUIT
- +9 ; FIELD 1
- SET B="VE^"
- +10 SET EDI=$PIECE(V3,U,2)
- +11 SET VID=$PIECE(V3,U,3)
- +12 IF EDI="Y"
- IF VID=""
- SET VAR2="NVID"
- +13 if VAR2]""
- QUIT
- +14 ; FIELD 2
- SET B=B_$SELECT(VID]"":VID,1:"")
- +15 ; FIELDS 3, 4, 5, 6, 7
- SET B=B_"^"_$PIECE(V,U)_"^"_$PIECE(V,U,2)_"^"_$PIECE(V,U,3)_"^"_$PIECE(V,U,4)_"^"_$PIECE(V,U,6)_"^"
- +16 SET ST=$GET(^DIC(5,$PIECE(V,U,7),0))
- +17 if ST=""
- SET VAR2="NST0"
- +18 if ST=""
- QUIT
- +19 if $PIECE(ST,U,2)=""
- SET VAR2="NSTA"
- +20 if VAR2]""
- QUIT
- +21 ; FIELDS 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20
- SET B=B_$EXTRACT($PIECE(ST,U,2),1,2)_"^"_$PIECE($PIECE(V,U,8),"-")_$PIECE($PIECE(V,U,8),"-",2)_"^"_$PIECE(V,U,10)_"^^^^^^^^^^|"
- VE1 SET ^TMP($JOB,"STRING",3)=B
- +1 QUIT
- +2 ;
- ST(A,A1,VAR1,VAR2) ;SHIP TO INFORMATION SEGMENT
- +1 NEW B,DDP,DDP0,EDI,FT,FT0,MP,NM,RL,SP0,ST,STS,VEN,SITE1
- +2 SET MP=$PIECE(A,U,2)
- SET DDP=$PIECE(A1,U,12)
- SET B="ST^"
- if MP=4&(DDP]"")
- GOTO STD
- +3 SET VEN=$PIECE(A1,U)
- SET V3=$GET(^PRC(440,VEN,3))
- SET EDI=$PIECE(V3,U,2)
- +4 SET SITE1=$GET(^PRC(442,VAR1,23))
- if SITE1]""
- SET SITE=$PIECE(SITE1,U,7)
- SET SITE=$SELECT($GET(SITE)]"":SITE,1:+$PIECE(A,U))
- +5 if SITE=""
- SET VAR2="NSIT"
- if SITE=""
- QUIT
- +6 SET ST=$PIECE(A1,U,3)
- +7 IF $PIECE(SITE1,U,11)="P"
- IF ST=""
- SET B=B_"^^^^^^^^^|"
- GOTO ST1
- +8 if ST=""
- SET VAR2="NSTL"
- if ST=""
- QUIT
- SET RL=$GET(^PRC(411,SITE,1,ST,0))
- if RL=""
- SET VAR2="NRL"
- if RL=""
- QUIT
- if $PIECE(RL,U,6)'>0
- SET VAR2="NSTT"
- if VAR2]""
- QUIT
- +9 SET STS=$PIECE(RL,U,9)
- IF EDI="Y"
- IF STS=""
- IF SITE'=101
- SET VAR2="NSTS"
- QUIT
- +10 SET B=B_$SELECT(STS]"":STS,1:"")
- SET SP0=$GET(^PRC(411,SITE,0))
- if SP0=""
- SET VAR2="NSP0^"_SITE
- if SP0=""
- QUIT
- SET FT=$PIECE(SP0,U,7)
- if FT=""
- SET VAR2="NFT^"_SITE
- if FT=""
- QUIT
- SET FT0=$GET(^PRC(411.2,FT,0))
- if FT0=""
- SET VAR2="NFT0^"_SITE
- if FT0=""
- QUIT
- +11 SET B=B_"^"_$SELECT($PIECE(FT0,U,2)]"":$PIECE(FT0,U,2),1:"V.A. *NO FACILITY TYPE*")_"^"
- +12 SET B=B_$EXTRACT($PIECE(RL,U,1),1,17)_" "_$PIECE($PIECE(A,U),"-",2)_"^"_$PIECE(RL,U,2)_"^"_$PIECE(RL,U,3)_"^"_$PIECE(RL,U,4)_"^"_$PIECE(RL,U,5)_"^"
- +13 SET ST=$GET(^DIC(5,$PIECE(RL,U,6),0))
- if ST=""
- SET VAR2="NST0"
- if ST=""
- QUIT
- if $PIECE(ST,U,2)=""
- SET VAR2="NSTA"
- if VAR2]""
- QUIT
- +14 SET B=B_$EXTRACT($PIECE(ST,U,2),1,2)_"^"_$PIECE($PIECE(RL,U,7),"-")_$PIECE($PIECE(RL,U,7),"-",2)_"^|"
- GOTO ST1
- STD SET NM=$GET(^DPT(DDP,0))
- if NM=""
- SET VAR2="NOPT"
- if NM=""
- QUIT
- SET NM=$EXTRACT($PIECE(NM,U),1,30)
- SET NM=$PIECE(NM,",",2)_" "_$PIECE(NM,",")
- +1 SET DDP0=$GET(^PRC(440.2,DDP,0))
- if DDP0=""
- SET VAR2="NDP0"
- if DDP0=""
- QUIT
- SET B=B_"^"_NM_"^"_$PIECE(DDP0,U,2)_"^"_$PIECE(DDP0,U,3)_"^"_$PIECE(DDP0,U,4)_"^^"
- if $PIECE(DDP0,U,6)'>0
- SET VAR2="NSTDP"
- if VAR2]""
- QUIT
- +2 SET ST=$GET(^DIC(5,$PIECE(DDP0,U,6),0))
- if ST=""
- SET VAR2="NST0"
- if ST=""
- QUIT
- if $PIECE(ST,U,2)=""
- SET VAR2="NSTA"
- if VAR2]""
- QUIT
- SET B=B_$PIECE(DDP0,U,5)_"^"_$EXTRACT($PIECE(ST,U,2),1,2)_"^"_$PIECE($PIECE(DDP0,U,7),"-")_$PIECE($PIECE(DDP0,U,7),"-",2)_"^|"
- ST1 SET ^TMP($JOB,"STRING",4)=B
- QUIT
