AIBCVT1.m

AIBCVT1 ;IHS/DDPS/DFM-IBM STAT RECORDS NODE PROCESSING [ 09/23/88  11:52 AM ]

 ;1.3; 9/23/88 RESTRUCTURE, ALLOW FOR REGISTRATION ELIGIBILITY FILE

 ;1.0; 3/28/88

PROCESS ;READ FACILITY HEADER RECORD

 S AIBZ=$O(@AIBGBLT) I AIBZ="" G EOJ

 S AIBZZ="",AIBZZ=$O(@AIBGBFT),AIBIN=@AIBGBFT I AIBZZ=0 G FACFOUND

 S AIBMSG="Facility Header Record Missing" G ABEND

FACFOUND ;FACILITY HEADER RECORD FOUND

 S AIBFNR=$P(AIBIN,U,5),AIBFCD=AIBZ,AIBFSQ=AIBFSQ+1 S:$L(AIBFSQ)>4 AIBFSQ=$E(AIBFSQ,2,5)+1

 S Y=$P(AIBIN,U,1) X ^DD("DD") S AIBFBD=Y,Y=$P(AIBIN,U,2) X ^DD("DD") S AIBFED=Y

 S AIBFCT=$P(AIBIN,U,3) D FACHEAD^AIBCVT2

READREC ;PROCESS INITIAL NODE FOR FACILITY

 S AIBCN1=1

READNODE ;PROCESS NEXT NODE

 S AIBZZ=$O(@AIBGBFT) I AIBZZ="" G NEXTFAC

 S AIBIN=@AIBGBFT,AIBNK=$P(AIBIN,U,1),AIBCK=$P(AIBC(AIBCN1),U,1),AIBC=$P(AIBC(AIBCN1),U,3)

 I AIBNK=AIBCK G GOODNODE

 I AIBCN1=AIBC(0) G CKTEMP

 F AIBC(0,0)=AIBCN1+1:1:AIBC(0) I AIBNK=$P(AIBC(AIBC(0,0)),U,1) G NODERR

CKTEMP ;CHECK IF SECONDARY FILE IS BEING CREATED

 I $L(AIBTMP)>0 D WRITET^AIBCVT3 G READREC

 G NODERR

GOODNODE ;PROCESS FIELDS IN NODE

 S AIBER=""

 F AIBI=1:1:AIBC D FIELDS^AIBCVT5 G:$L(AIBER)>0 ERROR

 S:AIBNK'="RG1" AIBCTI=AIBCTI+1

 G:AIBCN1=AIBC(0) EOD S AIBCN1=AIBCN1+1 G READNODE

NODERR ;PROCESS NODE ERROR

 S AIBMSG="Bad node key = "_AIBNK_" should be = "_AIBCK,AIBER="Y"

ERROR ;ERROR PROCESSING ROUTINE

 S AIBCTE=AIBCTE+1 D ERRMSP^AIBCVT6 G:AIBER="A" ABEND

 S AIBMSG=" Reject Node:"_AIBIN D ERRMSP^AIBCVT6 W ! G READREC

EOD ;RECORD COMPLETE

 S AIBCTO=AIBCTO+1

 I AIBRLN>250 G OVERFLOW

 S AIBOT=AIBOT_$J("",AIBRLN-$L(AIBOT))

 I $L(AIBOT)>AIBRLN S AIBOT=$E(AIBOT,1,AIBRLN)

 G WRITE

OVERFLOW ;MORE THAT 250 CHARACTER RECORD - OVERFLOW IN AIBOT(1)

 S AIBOT=AIBOT_$J("",250-$L(AIBOT))

 S AIBOT(1)=AIBOT(1)_$J("",AIBRLN-250-$L(AIBOT(1)))

 I $L(AIBOT(1))+$L(AIBOT)>AIBRLN S AIBOT(1)=$E(AIBOT(1),1,AIBRLN-$L(AIBOT))

WRITE ;PERFORM WRITE ROUTINE

 D ^AIBCVT3 G READREC

NEXTFAC ;WRITE FACILITY FOOTINGS, GO GET NEXT FACILITY

 D FACFOOT^AIBCVT2 G PROCESS

EOJ ;END OF GLOBAL PROCESSING

 S AIBA="E" G RETURN

ABEND ;ABNORMAL END OR PROCESSING

 S AIBA="A" G RETURN

RETURN ;RETURN TO CALLING ROUTINE

 QUIT

AIBCVT1   ;IHS/DDPS/DFM-IBM STAT RECORDS NODE PROCESSING [ 09/23/88  11:52 AM ]

 +1       ;1.3; 9/23/88 RESTRUCTURE, ALLOW FOR REGISTRATION ELIGIBILITY FILE

 +2       ;1.0; 3/28/88

PROCESS   ;READ FACILITY HEADER RECORD

 +1        SET AIBZ=$ORDER(@AIBGBLT)

           IF AIBZ=""

               GOTO EOJ

 +2        SET AIBZZ=""

           SET AIBZZ=$ORDER(@AIBGBFT)

           SET AIBIN=@AIBGBFT

           IF AIBZZ=0

               GOTO FACFOUND

 +3        SET AIBMSG="Facility Header Record Missing"

           GOTO ABEND

FACFOUND  ;FACILITY HEADER RECORD FOUND

 +1        SET AIBFNR=$PIECE(AIBIN,U,5)

           SET AIBFCD=AIBZ

           SET AIBFSQ=AIBFSQ+1

           IF $LENGTH(AIBFSQ)>4

               SET AIBFSQ=$EXTRACT(AIBFSQ,2,5)+1

 +2        SET Y=$PIECE(AIBIN,U,1)

           XECUTE ^DD("DD")

           SET AIBFBD=Y

           SET Y=$PIECE(AIBIN,U,2)

           XECUTE ^DD("DD")

           SET AIBFED=Y

 +3        SET AIBFCT=$PIECE(AIBIN,U,3)

           DO FACHEAD^AIBCVT2

READREC   ;PROCESS INITIAL NODE FOR FACILITY

 +1        SET AIBCN1=1

READNODE  ;PROCESS NEXT NODE

 +1        SET AIBZZ=$ORDER(@AIBGBFT)

           IF AIBZZ=""

               GOTO NEXTFAC

 +2        SET AIBIN=@AIBGBFT

           SET AIBNK=$PIECE(AIBIN,U,1)

           SET AIBCK=$PIECE(AIBC(AIBCN1),U,1)

           SET AIBC=$PIECE(AIBC(AIBCN1),U,3)

 +3        IF AIBNK=AIBCK

               GOTO GOODNODE

 +4        IF AIBCN1=AIBC(0)

               GOTO CKTEMP

 +5        FOR AIBC(0,0)=AIBCN1+1:1:AIBC(0)

               IF AIBNK=$PIECE(AIBC(AIBC(0,0)),U,1)

                   GOTO NODERR

CKTEMP    ;CHECK IF SECONDARY FILE IS BEING CREATED

 +1        IF $LENGTH(AIBTMP)>0

               DO WRITET^AIBCVT3

               GOTO READREC

 +2        GOTO NODERR

GOODNODE  ;PROCESS FIELDS IN NODE

 +1        SET AIBER=""

 +2        FOR AIBI=1:1:AIBC

               DO FIELDS^AIBCVT5

               IF $LENGTH(AIBER)>0

                   GOTO ERROR

 +3        IF AIBNK'="RG1"

               SET AIBCTI=AIBCTI+1

 +4        IF AIBCN1=AIBC(0)

               GOTO EOD

           SET AIBCN1=AIBCN1+1

           GOTO READNODE

NODERR    ;PROCESS NODE ERROR

 +1        SET AIBMSG="Bad node key = "_AIBNK_" should be = "_AIBCK

           SET AIBER="Y"

ERROR     ;ERROR PROCESSING ROUTINE

 +1        SET AIBCTE=AIBCTE+1

           DO ERRMSP^AIBCVT6

           IF AIBER="A"

               GOTO ABEND

 +2        SET AIBMSG=" Reject Node:"_AIBIN

           DO ERRMSP^AIBCVT6

           WRITE !

           GOTO READREC

EOD       ;RECORD COMPLETE

 +1        SET AIBCTO=AIBCTO+1

 +2        IF AIBRLN>250

               GOTO OVERFLOW

 +3        SET AIBOT=AIBOT_$JUSTIFY("",AIBRLN-$LENGTH(AIBOT))

 +4        IF $LENGTH(AIBOT)>AIBRLN

               SET AIBOT=$EXTRACT(AIBOT,1,AIBRLN)

 +5        GOTO WRITE

OVERFLOW  ;MORE THAT 250 CHARACTER RECORD - OVERFLOW IN AIBOT(1)

 +1        SET AIBOT=AIBOT_$JUSTIFY("",250-$LENGTH(AIBOT))

 +2        SET AIBOT(1)=AIBOT(1)_$JUSTIFY("",AIBRLN-250-$LENGTH(AIBOT(1)))

 +3        IF $LENGTH(AIBOT(1))+$LENGTH(AIBOT)>AIBRLN

               SET AIBOT(1)=$EXTRACT(AIBOT(1),1,AIBRLN-$LENGTH(AIBOT))

WRITE     ;PERFORM WRITE ROUTINE

 +1        DO ^AIBCVT3

           GOTO READREC

NEXTFAC   ;WRITE FACILITY FOOTINGS, GO GET NEXT FACILITY

 +1        DO FACFOOT^AIBCVT2

           GOTO PROCESS

EOJ       ;END OF GLOBAL PROCESSING

 +1        SET AIBA="E"

           GOTO RETURN

ABEND     ;ABNORMAL END OR PROCESSING

 +1        SET AIBA="A"

           GOTO RETURN

RETURN    ;RETURN TO CALLING ROUTINE

 +1        QUIT