PRCHFPD3 ;WASH-CIOFO/SC-FPDS INPUT TRANSFORM FROM FILE 420.6 ;7/24/00 23:06
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;This routine is only excutable at an entry point.
Q
EN1 ;Input Transform of Field #5 in File #420.6
N I,PRCLNGTH,PRCHBUS,ARR,J,PRCHTYP
K:$L(X)<1!($L(X)>30) X
Q:'$D(X)
S PRCLNGTH=$L(X)
F I=1:1:PRCLNGTH D
. S PRCHBUS=$E(X,I)
. I PRCHBUS=+PRCHBUS,1234[PRCHBUS D
. . S ARR(PRCHBUS)=""
. . Q
. Q
;
;Restore the proper values for Business Type and comma as a delimiter
;for more than one Applicable Bus. Type for specific Socio. Group
;
S J=""
S J=$O(ARR(J)) Q:J=""!(J'=+J)
S X=J
F S J=$O(ARR(J)) Q:J="" D
. S X=X_","_J
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHFPD3 747 printed Nov 22, 2024@17:17:39 Page 2
PRCHFPD3 ;WASH-CIOFO/SC-FPDS INPUT TRANSFORM FROM FILE 420.6 ;7/24/00 23:06
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;This routine is only excutable at an entry point.
+3 QUIT
EN1 ;Input Transform of Field #5 in File #420.6
+1 NEW I,PRCLNGTH,PRCHBUS,ARR,J,PRCHTYP
+2 if $LENGTH(X)<1!($LENGTH(X)>30)
KILL X
+3 if '$DATA(X)
QUIT
+4 SET PRCLNGTH=$LENGTH(X)
+5 FOR I=1:1:PRCLNGTH
Begin DoDot:1
+6 SET PRCHBUS=$EXTRACT(X,I)
+7 IF PRCHBUS=+PRCHBUS
IF 1234[PRCHBUS
Begin DoDot:2
+8 SET ARR(PRCHBUS)=""
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 ;
+12 ;Restore the proper values for Business Type and comma as a delimiter
+13 ;for more than one Applicable Bus. Type for specific Socio. Group
+14 ;
+15 SET J=""
+16 SET J=$ORDER(ARR(J))
if J=""!(J'=+J)
QUIT
+17 SET X=J
+18 FOR
SET J=$ORDER(ARR(J))
if J=""
QUIT
Begin DoDot:1
+19 SET X=X_","_J
+20 QUIT
End DoDot:1
+21 QUIT
