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
Q
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
