Routine: AIBCVT0

AIBCVT0 ;IHS/DDPS/DFM-IBM STAT RECORDS CONTROL PARAMETERS [ 01/12/89  1:06 PM ]

 ;1.3; 1/13/89 CONTROLS FOR PARKLAWN AND NIH

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

 ;1.0; 3/28/88

CONTROL ;READ CONTROL GLOBAL TO DETERMINE SYSTEM AND FIELD CHARACTERISTICS

 K AIBC,AIBB S AIBCS="",AIBCS=$O(^AIBCVTC("C",""_AIBGBLP_"",AIBCS))

 G:$L(AIBCS)>0 CTLFOUND

 S AIBA="A",AIBMSG="No Control Global Entry for "_AIBGBLP

 D ERRMSG^AIBCVT6 G RETURN

CTLFOUND ;CONTROL GLOBAL FOUND FOR RECORDS SYSTEM

 S AIBCN1="",AIBCN2=0

 S AIBTGBL="",AIBTMP="",AIBTGLT="",AIBTGFT=""

 I $L(AIB2ND)=0 G NEWFILE

 I AIBCF=$P(^AIBCVTC(AIBCS,0),U,3)!((AIBFILE="ibmjob")&(AIBGBLP="AGEL")) S AIBT2="A" G CK2ND

NEWFILE ;CREATE A NEW OUTPUT FILE

 S AIBT2="W" S:'$D(AIBOK) AIBFFN=""

 I AIBOS="D"!('$D(AIBT1)) G CK2ND

 S AIBMSG="File Created : "_AIBT1 D ERRMSG^AIBCVT6

CK2ND ;CHECK IF TEMPORARY FILE FOR 2ND RECORD FORMAT IS NEEDED

 S AIB2ND=$P(^AIBCVTC(AIBCS,0),U,4)

 I $L(AIB2ND)=0 G GETNAME

 S AIBTGBL=$P(^AIBCVTC(AIB2ND,0),U,2),AIBTMP=U_AIBTGBL_"GLOB"

 S AIBTGLT=AIBTMP_"(AIBZ)",AIBTGFT=AIBTMP_"(AIBZ,AIBTZ)",AIBTZ(1)=0

GETNAME ;GET OUTPUT FILE NAME

 S AIBCNM=$P(^AIBCVTC(AIBCS,0),U,1)

 S AIBCN3=""

 I AIBGBLP="AGEL" I AIBFILE="ibmjob" G CTLOOPN

 S AIBCF=$P(^AIBCVTC(AIBCS,0),U,3)

CTLOOPN ;GET CONTROL FOR ALL NODES IN RECORD

 S AIBCN3=$O(^AIBCVTC(AIBCS,1,"C",AIBCN3)) G:AIBCN3="" CTLNDONE

 S AIBCN2=AIBCN2+1,AIBCF2=0,AIBCF3=""

 S AIBCN1="",AIBCN1=$O(^AIBCVTC(AIBCS,1,"C",AIBCN3,AIBCN1))

 S AIBC(AIBCN2)=^AIBCVTC(AIBCS,1,AIBCN1,0)

CTLOOPF ;GET CONTROL FOR ALL FIELDS IN NODE

 S AIBCF3=$O(^AIBCVTC(AIBCS,1,AIBCN1,1,"C",AIBCF3))

 I AIBCF3="" G CTLFDONE

 S AIBCF2=AIBCF2+1

 S AIBCF1="",AIBCF1=$O(^AIBCVTC(AIBCS,1,AIBCN1,1,"C",AIBCF3,AIBCF1))

 S AIBC(AIBCN1,AIBCF2)=^AIBCVTC(AIBCS,1,AIBCN1,1,AIBCF1,0) G CTLOOPF

CTLFDONE ;CONTROL FOR ALL FIELDS IN NODE LOADED

 S $P(AIBC(AIBCN2),U,3)=AIBCF2

 G CTLOOPN

CTLNDONE ;CONTROL FOR ALL NODES LOADED

 S AIBCL=$P(AIBC(AIBCN2,AIBCF2),U,2),AIBL=$P(AIBC(AIBCN2,AIBCF2),U,3)

 S AIBRLN=AIBCL+AIBL-1

 S AIBC(0)=AIBCN2 I AIBFILE="keytap" S AIBJ="" G RETURN

 D ^AIBCVT00 G:AIBA="A" RETURN

SETRJE ;SETUP TO GET RJE DATA

 S AIBB2=0,AIBB3=""

CTLOOPB ;GET CONTROL INFORMATION FOR RJE JOB BYSYNC TELECOMMUNICATIONS CARD

 S AIBB3=$O(^AIBCVTC(AIBCS,2,"C",AIBB3))

 I AIBB2=0 I AIBB3="" S AIBA="A",AIBMSG="No Control Global Entry for "_AIBGBLP_" RJE Cards" D ERRMSG^AIBCVT6 G RETURN

 I AIBB3="" G RETURN

 S AIBB2=AIBB2+1,AIBB1="",AIBB1=$O(^AIBCVTC(AIBCS,2,"C",AIBB3,AIBB1))

 S AIBB(AIBB2)=^AIBCVTC(AIBCS,2,AIBB1,0)

 G CTLOOPB

BJCL ;WRITE BEGINNING JCL FOR RJE BYSYNC JOB

 S AIBJ=0,AIBJC=$P(^AIBCVTC(AIBCS,0),U,5)

BJCLOOP ;WRITE NEXT BEGINNING JCL CARD

 S AIBJ=$O(^AIBCVTJ(AIBJC,1,AIBJ)) G:AIBJ="" RETURN

 S AIBOT=$P(^AIBCVTJ(AIBJC,1,AIBJ,0),U,2)

RESOLVE1 ;RESOLVE AREA CODES

 I AIBOT["|" S AIBOW=$P(AIBOT,"|",1),AIBTLN=$L(AIBOW)+2,AIBOW2=$E(AIBOT,AIBTLN,999),AIBOT=AIBOW_AIBJSAC_AIBOW2 G RESOLVE1

RESOLVE2 ;DDPS REMOTE NUMBER

 I AIBOT["~" S AIBOW=$P(AIBOT,"~",1),AIBTLN=$L(AIBOW)+2,AIBOW2=$E(AIBOT,AIBTLN,999),AIBOT=AIBOW_AIBJSRD_AIBOW2 G RESOLVE2

RESOLVE3 ;ACCOUNTING POINT

 I AIBOT["#" S AIBOW=$P(AIBOT,"#",1),AIBTLN=$L(AIBOW)+2,AIBOW2=$E(AIBOT,AIBTLN,999),AIBOT=AIBOW_AIBJSAP_AIBOW2 G RESOLVE3

RESOLVE4 ;AREA NAME

 I AIBOT["@" S AIBOW=$P(AIBOT,"@",1),AIBTLN=$L(AIBOW)+2,AIBOW2=$E(AIBOT,AIBTLN,999),AIBOT=AIBOW_AIBJSAN_AIBOW2 G RESOLVE4

RESOLVE5 ;PARKLAWN REMOTE NUMBER

 I AIBOT["`" S AIBOW=$P(AIBOT,"`",1),AIBTLN=$L(AIBOW)+2,AIBOW2=$E(AIBOT,AIBTLN,999),AIBOT=AIBOW_AIBJSRP_AIBOW2 G RESOLVE5

RESOLVE6 ;NIH REMOTE NUMBER

 I AIBOT["!" S AIBOW=$P(AIBOT,"!",1),AIBTLN=$L(AIBOW)+2,AIBOW2=$E(AIBOT,AIBTLN,999),AIBOT=AIBOW_AIBJSRN_AIBOW2 G RESOLVE6

 K AIBOW2,AIBTLN

 D WRITE^AIBCVT3 S AIBCTJ=AIBCTJ+1 G BJCLOOP

EJCL ;WRITE ENDING JCL FOR RJE BYSYNC JOB

 S AIBJ=0

EJCLOOP ;WRITE NEXT ENDING JCL CARD

 S AIBJ=$O(^AIBCVTJ(AIBJC,2,AIBJ)) G:AIBJ="" RETURN

 S AIBOT=$P(^AIBCVTJ(AIBJC,2,AIBJ,0),U,2)

 D WRITE^AIBCVT3 S AIBCTJ=AIBCTJ+1 G EJCLOOP

RETURN ;RETURN TO CALLING ROUTINE

AIBCVT0   ;IHS/DDPS/DFM-IBM STAT RECORDS CONTROL PARAMETERS [ 01/12/89  1:06 PM ]

 +1       ;1.3; 1/13/89 CONTROLS FOR PARKLAWN AND NIH

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

 +3       ;1.0; 3/28/88

CONTROL   ;READ CONTROL GLOBAL TO DETERMINE SYSTEM AND FIELD CHARACTERISTICS

 +1        KILL AIBC,AIBB

           SET AIBCS=""

           SET AIBCS=$ORDER(^AIBCVTC("C",""_AIBGBLP_"",AIBCS))

 +2        IF $LENGTH(AIBCS)>0

               GOTO CTLFOUND

 +3        SET AIBA="A"

           SET AIBMSG="No Control Global Entry for "_AIBGBLP

 +4        DO ERRMSG^AIBCVT6

           GOTO RETURN

CTLFOUND  ;CONTROL GLOBAL FOUND FOR RECORDS SYSTEM

 +1        SET AIBCN1=""

           SET AIBCN2=0

 +2        SET AIBTGBL=""

           SET AIBTMP=""

           SET AIBTGLT=""

           SET AIBTGFT=""

 +3        IF $LENGTH(AIB2ND)=0

               GOTO NEWFILE

 +4        IF AIBCF=$PIECE(^AIBCVTC(AIBCS,0),U,3)!((AIBFILE="ibmjob")&(AIBGBLP="AGEL"))

               SET AIBT2="A"

               GOTO CK2ND

NEWFILE   ;CREATE A NEW OUTPUT FILE

 +1        SET AIBT2="W"

           IF '$DATA(AIBOK)

               SET AIBFFN=""

 +2        IF AIBOS="D"!('$DATA(AIBT1))

               GOTO CK2ND

 +3        SET AIBMSG="File Created : "_AIBT1

           DO ERRMSG^AIBCVT6

CK2ND     ;CHECK IF TEMPORARY FILE FOR 2ND RECORD FORMAT IS NEEDED

 +1        SET AIB2ND=$PIECE(^AIBCVTC(AIBCS,0),U,4)

 +2        IF $LENGTH(AIB2ND)=0

               GOTO GETNAME

 +3        SET AIBTGBL=$PIECE(^AIBCVTC(AIB2ND,0),U,2)

           SET AIBTMP=U_AIBTGBL_"GLOB"

 +4        SET AIBTGLT=AIBTMP_"(AIBZ)"

           SET AIBTGFT=AIBTMP_"(AIBZ,AIBTZ)"

           SET AIBTZ(1)=0

GETNAME   ;GET OUTPUT FILE NAME

 +1        SET AIBCNM=$PIECE(^AIBCVTC(AIBCS,0),U,1)

 +2        SET AIBCN3=""

 +3        IF AIBGBLP="AGEL"

               IF AIBFILE="ibmjob"

                   GOTO CTLOOPN

 +4        SET AIBCF=$PIECE(^AIBCVTC(AIBCS,0),U,3)

CTLOOPN   ;GET CONTROL FOR ALL NODES IN RECORD

 +1        SET AIBCN3=$ORDER(^AIBCVTC(AIBCS,1,"C",AIBCN3))

           IF AIBCN3=""

               GOTO CTLNDONE

 +2        SET AIBCN2=AIBCN2+1

           SET AIBCF2=0

           SET AIBCF3=""

 +3        SET AIBCN1=""

           SET AIBCN1=$ORDER(^AIBCVTC(AIBCS,1,"C",AIBCN3,AIBCN1))

 +4        SET AIBC(AIBCN2)=^AIBCVTC(AIBCS,1,AIBCN1,0)

CTLOOPF   ;GET CONTROL FOR ALL FIELDS IN NODE

 +1        SET AIBCF3=$ORDER(^AIBCVTC(AIBCS,1,AIBCN1,1,"C",AIBCF3))

 +2        IF AIBCF3=""

               GOTO CTLFDONE

 +3        SET AIBCF2=AIBCF2+1

 +4        SET AIBCF1=""

           SET AIBCF1=$ORDER(^AIBCVTC(AIBCS,1,AIBCN1,1,"C",AIBCF3,AIBCF1))

 +5        SET AIBC(AIBCN1,AIBCF2)=^AIBCVTC(AIBCS,1,AIBCN1,1,AIBCF1,0)

           GOTO CTLOOPF

CTLFDONE  ;CONTROL FOR ALL FIELDS IN NODE LOADED

 +1        SET $PIECE(AIBC(AIBCN2),U,3)=AIBCF2

 +2        GOTO CTLOOPN

CTLNDONE  ;CONTROL FOR ALL NODES LOADED

 +1        SET AIBCL=$PIECE(AIBC(AIBCN2,AIBCF2),U,2)

           SET AIBL=$PIECE(AIBC(AIBCN2,AIBCF2),U,3)

 +2        SET AIBRLN=AIBCL+AIBL-1

 +3        SET AIBC(0)=AIBCN2

           IF AIBFILE="keytap"

               SET AIBJ=""

               GOTO RETURN

 +4        DO ^AIBCVT00

           IF AIBA="A"

               GOTO RETURN

SETRJE    ;SETUP TO GET RJE DATA

 +1        SET AIBB2=0

           SET AIBB3=""

CTLOOPB   ;GET CONTROL INFORMATION FOR RJE JOB BYSYNC TELECOMMUNICATIONS CARD

 +1        SET AIBB3=$ORDER(^AIBCVTC(AIBCS,2,"C",AIBB3))

 +2        IF AIBB2=0

               IF AIBB3=""

                   SET AIBA="A"

                   SET AIBMSG="No Control Global Entry for "_AIBGBLP_" RJE Cards"

                   DO ERRMSG^AIBCVT6

                   GOTO RETURN

 +3        IF AIBB3=""

               GOTO RETURN

 +4        SET AIBB2=AIBB2+1

           SET AIBB1=""

           SET AIBB1=$ORDER(^AIBCVTC(AIBCS,2,"C",AIBB3,AIBB1))

 +5        SET AIBB(AIBB2)=^AIBCVTC(AIBCS,2,AIBB1,0)

 +6        GOTO CTLOOPB

BJCL      ;WRITE BEGINNING JCL FOR RJE BYSYNC JOB

 +1        SET AIBJ=0

           SET AIBJC=$PIECE(^AIBCVTC(AIBCS,0),U,5)

BJCLOOP   ;WRITE NEXT BEGINNING JCL CARD

 +1        SET AIBJ=$ORDER(^AIBCVTJ(AIBJC,1,AIBJ))

           IF AIBJ=""

               GOTO RETURN

 +2        SET AIBOT=$PIECE(^AIBCVTJ(AIBJC,1,AIBJ,0),U,2)

RESOLVE1  ;RESOLVE AREA CODES

 +1        IF AIBOT["|"

               SET AIBOW=$PIECE(AIBOT,"|",1)

               SET AIBTLN=$LENGTH(AIBOW)+2

               SET AIBOW2=$EXTRACT(AIBOT,AIBTLN,999)

               SET AIBOT=AIBOW_AIBJSAC_AIBOW2

               GOTO RESOLVE1

RESOLVE2  ;DDPS REMOTE NUMBER

 +1        IF AIBOT["~"

               SET AIBOW=$PIECE(AIBOT,"~",1)

               SET AIBTLN=$LENGTH(AIBOW)+2

               SET AIBOW2=$EXTRACT(AIBOT,AIBTLN,999)

               SET AIBOT=AIBOW_AIBJSRD_AIBOW2

               GOTO RESOLVE2

RESOLVE3  ;ACCOUNTING POINT

 +1        IF AIBOT["#"

               SET AIBOW=$PIECE(AIBOT,"#",1)

               SET AIBTLN=$LENGTH(AIBOW)+2

               SET AIBOW2=$EXTRACT(AIBOT,AIBTLN,999)

               SET AIBOT=AIBOW_AIBJSAP_AIBOW2

               GOTO RESOLVE3

RESOLVE4  ;AREA NAME

 +1        IF AIBOT["@"

               SET AIBOW=$PIECE(AIBOT,"@",1)

               SET AIBTLN=$LENGTH(AIBOW)+2

               SET AIBOW2=$EXTRACT(AIBOT,AIBTLN,999)

               SET AIBOT=AIBOW_AIBJSAN_AIBOW2

               GOTO RESOLVE4

RESOLVE5  ;PARKLAWN REMOTE NUMBER

 +1        IF AIBOT["`"

               SET AIBOW=$PIECE(AIBOT,"`",1)

               SET AIBTLN=$LENGTH(AIBOW)+2

               SET AIBOW2=$EXTRACT(AIBOT,AIBTLN,999)

               SET AIBOT=AIBOW_AIBJSRP_AIBOW2

               GOTO RESOLVE5

RESOLVE6  ;NIH REMOTE NUMBER

 +1        IF AIBOT["!"

               SET AIBOW=$PIECE(AIBOT,"!",1)

               SET AIBTLN=$LENGTH(AIBOW)+2

               SET AIBOW2=$EXTRACT(AIBOT,AIBTLN,999)

               SET AIBOT=AIBOW_AIBJSRN_AIBOW2

               GOTO RESOLVE6

 +2        KILL AIBOW2,AIBTLN

 +3        DO WRITE^AIBCVT3

           SET AIBCTJ=AIBCTJ+1

           GOTO BJCLOOP

EJCL      ;WRITE ENDING JCL FOR RJE BYSYNC JOB

 +1        SET AIBJ=0

EJCLOOP   ;WRITE NEXT ENDING JCL CARD

 +1        SET AIBJ=$ORDER(^AIBCVTJ(AIBJC,2,AIBJ))

           IF AIBJ=""

               GOTO RETURN

 +2        SET AIBOT=$PIECE(^AIBCVTJ(AIBJC,2,AIBJ,0),U,2)

 +3        DO WRITE^AIBCVT3

           SET AIBCTJ=AIBCTJ+1

           GOTO EJCLOOP

RETURN    ;RETURN TO CALLING ROUTINE

 +1        QUIT

AIBCVT0.m