- 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
