PRCHFPD3.m

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 ---PRCHFPD3   747     printed  Apr 09, 2024@21:02:17                                                                                                                                                                                                     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