AIBCVT5 ;IHS/DDPS/DFM-IBM STAT RECORDS FIELD PROCESS [ 12/01/88 3:46 PM ]
;1.3; 9/23/88 RESTRUCTURE, ALLOW FOR REGISTRATION ELIGIBILITY FILE
;1.0; 3/28/88
FIELDS ;BUILD RECORD FIELDS
S AIBN=$P(AIBC(AIBCN1,AIBI),U,1)
S AIBB=$P(AIBC(AIBCN1,AIBI),U,2)
S AIBL=$P(AIBC(AIBCN1,AIBI),U,3)
S AIBE=AIBB-1,AIBOL(0)=$L(AIBOT)
S AIBOL(1)=$L(AIBOT(1))
S AIBOL=AIBOL(0)+AIBOL(1)
S AIBFC=$P(AIBC(AIBCN1,AIBI),U,4)
S AIBED=$P(AIBC(AIBCN1,AIBI),U,5)
S AIBLE=$P(AIBC(AIBCN1,AIBI),U,6)
S AIBI2=AIBI+1,X=$P(AIBIN,U,AIBI2) I $E(X,$L(X))=$C(13) S X=$E(X,1,$L(X)-1)
G:$L(AIBED)=0 EDITOK X AIBED G:AIBG="R" RETURN G:AIBG="W" WRITE
I AIBER="" G EDITOK
I AIBER='WARN G CKMSG
S AIBER=""
S:$D(AIBPID) AIBMSG=AIBMSG_" for patient "_AIBZ_AIBPID
D ERRMSP^AIBCVT6 G EDITOK
CKMSG ;CHECK FOR OTHER ERROR MESSAGE
D:$L(AIBMSG)>0 ERRMSP^AIBCVT6
S AIBMSG="Edit error on field "_AIBN_" value was "_X
I $D(AIBPID) S AIBMSG=AIBMSG_" for patient "_AIBZ_AIBPID
D ERRMSP^AIBCVT6
G RETURN
EDITOK ;CHECK FIELD LENGTH
S AIBER="" G:$L(X)=AIBL MOVE G:$L(X)<AIBL FILLOGIC
S AIBMSG="Field "_AIBN_" too long should be "_AIBL
S AIBMSG=AIBMSG_" but is "_$L(X)_" value is "_X
I $D(AIBPID) S AIBMSG=AIBMSG_" for patient "_AIBZ_AIBPID
D ERRMSP^AIBCVT6
I AIBLE="A" S AIBMSG="Program Aborted",AIBER="A" G RETURN
I AIBLE="R" S AIBER="Y",AIBI=AIBC G RETURN
I AIBLE="" G TRUNCATE
S X="",AIBMSG=" field set to spaces" D ERRMSP^AIBCVT6 G BLANK
TRUNCATE ;TRUNCATE FIELD TO FIT
S X=$E(X,1,AIBL),AIBMSG=" Truncated to "_X D ERRMSP^AIBCVT6 G MOVE
FILLOGIC ;LOGIC FOR FILLING SHORT FIELDS
G:AIBFC="B" BLANK G:X="" BLANK G:AIBFC="S" STRIPDP G ZEROES
STRIPDP ;STRIP DECIMAL POINT FROM ICD9 CODES
S Y=$F(X,"."),X=$E(X,1,Y-2)_$E(X,Y,$L(AIBL))
S:X?1"E"4N X=$E(X,2,5) S:X?1"E"3N1" " X=$E(X,2,4) G MOVE
BLANK ;FIELD SHOULD BE LEFT JUSTIFIED FILL WITH BLANK TO RIGHT
S X=X_$J("",AIBL-$L(X)) G MOVE
ZEROES ;FIELD SHOULD BE RIGHT JUSTIFIED FILL WITH ZEROES TO LEFT
S AIBZR=$E(AIBZRS,1,AIBL-$L(X)),X=AIBZR_X
MOVE ;ADD FIELD TO OUTPUT RECORD
I 250>AIBE+AIBL G MOVE2
S:AIBOL(0)<250 AIBOT=AIBOT_$E(X,1,250-AIBOL(0)),X=$E(X,250-AIBOL(0),256)
G MOVOVFL
MOVE2 ;
I AIBE>AIBOL(0) G MOVE3
S AIBOT=$E(AIBOT,1,AIBE)_X_$E(AIBOT,AIBB+AIBL-1,250-AIBL) G CKINS
MOVE3 ;
I AIBOL(0)<AIBE S AIBOT=AIBOT_$J("",AIBB-$L(AIBOT)-1)_X G CKINS
I AIBOL(0)=AIBE S AIBOT=AIBOT_X G CKINS
MOVOVFL ;ADD FIELD TO OVERFLOW RECORD
I AIBE-AIBOL(0)>AIBOL(1) G MOVOVF2
S AIBOT(1)=$E(AIBOT(1),1,AIBE-AIBOL(0))_X_$E(AIBOT(1),AIBB-AIBOL(0)+AIBL-1,255) G CKINS
MOVOVF2 ;
I AIBE-AIBOL(0)<AIBOL G MOVOVF3
S AIBOT(1)=AIBOT(1)_$J("",AIBB-AIBOL(0)-$L(AIBOT(1))-1)_X G CKINS
MOVOVF3 ;
I AIBOL=AIBE S AIBOT(1)=AIBOT(1)_X G CKINS
CKINS ;CHECK IF PIECE IS TO TO INSERTED INTO NODE
G:AIBG="I" INSPIECE G RETURN
INSPIECE ;INSERT MISSING PIECE IN INPUT NODE
S AIBI(0)=0 F AIBI3=1:1:AIBI S AIBI(0)=AIBI(0)+$L($P(AIBIN,U,AIBI3))
S AIBIN=$E(AIBIN,1,AIBI(0))_U_$E(AIBIN,AIBI(0)+1,999) G RETURN
WRITE ;WRITE ABILITY FOR REGISTRATION HEADER RECORD
S AIBH2=X_$J("",14-$L(X)),AIBOT=AIBH1_AIBH2_AIBH3
I AIBGBLP="AGHA" S AIBOT=AIBOT_AIBH4
E S AIBOT=AIBOT_AIBH5
S AIBOT=AIBOT_$J("",250-$L(AIBOT)),AIBOT(1)=$J("",60)
S AIBCTB=AIBCTB+1 D ^AIBCVT3
RETURN ;RETURN TO CALLING ROUTINE
S AIBG="" Q
AIBCVT5 ;IHS/DDPS/DFM-IBM STAT RECORDS FIELD PROCESS [ 12/01/88 3:46 PM ]
+1 ;1.3; 9/23/88 RESTRUCTURE, ALLOW FOR REGISTRATION ELIGIBILITY FILE
+2 ;1.0; 3/28/88
FIELDS ;BUILD RECORD FIELDS
+1 SET AIBN=$PIECE(AIBC(AIBCN1,AIBI),U,1)
+2 SET AIBB=$PIECE(AIBC(AIBCN1,AIBI),U,2)
+3 SET AIBL=$PIECE(AIBC(AIBCN1,AIBI),U,3)
+4 SET AIBE=AIBB-1
SET AIBOL(0)=$LENGTH(AIBOT)
+5 SET AIBOL(1)=$LENGTH(AIBOT(1))
+6 SET AIBOL=AIBOL(0)+AIBOL(1)
+7 SET AIBFC=$PIECE(AIBC(AIBCN1,AIBI),U,4)
+8 SET AIBED=$PIECE(AIBC(AIBCN1,AIBI),U,5)
+9 SET AIBLE=$PIECE(AIBC(AIBCN1,AIBI),U,6)
+10 SET AIBI2=AIBI+1
SET X=$PIECE(AIBIN,U,AIBI2)
IF $EXTRACT(X,$LENGTH(X))=$CHAR(13)
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
+11 IF $LENGTH(AIBED)=0
GOTO EDITOK
XECUTE AIBED
IF AIBG="R"
GOTO RETURN
IF AIBG="W"
GOTO WRITE
+12 IF AIBER=""
GOTO EDITOK
+13 IF AIBER='WARN
GOTO CKMSG
+14 SET AIBER=""
+15 IF $DATA(AIBPID)
SET AIBMSG=AIBMSG_" for patient "_AIBZ_AIBPID
+16 DO ERRMSP^AIBCVT6
GOTO EDITOK
CKMSG ;CHECK FOR OTHER ERROR MESSAGE
+1 IF $LENGTH(AIBMSG)>0
DO ERRMSP^AIBCVT6
+2 SET AIBMSG="Edit error on field "_AIBN_" value was "_X
+3 IF $DATA(AIBPID)
SET AIBMSG=AIBMSG_" for patient "_AIBZ_AIBPID
+4 DO ERRMSP^AIBCVT6
+5 GOTO RETURN
EDITOK ;CHECK FIELD LENGTH
+1 SET AIBER=""
IF $LENGTH(X)=AIBL
GOTO MOVE
IF $LENGTH(X)<AIBL
GOTO FILLOGIC
+2 SET AIBMSG="Field "_AIBN_" too long should be "_AIBL
+3 SET AIBMSG=AIBMSG_" but is "_$LENGTH(X)_" value is "_X
+4 IF $DATA(AIBPID)
SET AIBMSG=AIBMSG_" for patient "_AIBZ_AIBPID
+5 DO ERRMSP^AIBCVT6
+6 IF AIBLE="A"
SET AIBMSG="Program Aborted"
SET AIBER="A"
GOTO RETURN
+7 IF AIBLE="R"
SET AIBER="Y"
SET AIBI=AIBC
GOTO RETURN
+8 IF AIBLE=""
GOTO TRUNCATE
+9 SET X=""
SET AIBMSG=" field set to spaces"
DO ERRMSP^AIBCVT6
GOTO BLANK
TRUNCATE ;TRUNCATE FIELD TO FIT
+1 SET X=$EXTRACT(X,1,AIBL)
SET AIBMSG=" Truncated to "_X
DO ERRMSP^AIBCVT6
GOTO MOVE
FILLOGIC ;LOGIC FOR FILLING SHORT FIELDS
+1 IF AIBFC="B"
GOTO BLANK
IF X=""
GOTO BLANK
IF AIBFC="S"
GOTO STRIPDP
GOTO ZEROES
STRIPDP ;STRIP DECIMAL POINT FROM ICD9 CODES
+1 SET Y=$FIND(X,".")
SET X=$EXTRACT(X,1,Y-2)_$EXTRACT(X,Y,$LENGTH(AIBL))
+2 IF X?1"E"4N
SET X=$EXTRACT(X,2,5)
IF X?1"E"3N1" "
SET X=$EXTRACT(X,2,4)
GOTO MOVE
BLANK ;FIELD SHOULD BE LEFT JUSTIFIED FILL WITH BLANK TO RIGHT
+1 SET X=X_$JUSTIFY("",AIBL-$LENGTH(X))
GOTO MOVE
ZEROES ;FIELD SHOULD BE RIGHT JUSTIFIED FILL WITH ZEROES TO LEFT
+1 SET AIBZR=$EXTRACT(AIBZRS,1,AIBL-$LENGTH(X))
SET X=AIBZR_X
MOVE ;ADD FIELD TO OUTPUT RECORD
+1 IF 250>AIBE+AIBL
GOTO MOVE2
+2 IF AIBOL(0)<250
SET AIBOT=AIBOT_$EXTRACT(X,1,250-AIBOL(0))
SET X=$EXTRACT(X,250-AIBOL(0),256)
+3 GOTO MOVOVFL
MOVE2 ;
+1 IF AIBE>AIBOL(0)
GOTO MOVE3
+2 SET AIBOT=$EXTRACT(AIBOT,1,AIBE)_X_$EXTRACT(AIBOT,AIBB+AIBL-1,250-AIBL)
GOTO CKINS
MOVE3 ;
+1 IF AIBOL(0)<AIBE
SET AIBOT=AIBOT_$JUSTIFY("",AIBB-$LENGTH(AIBOT)-1)_X
GOTO CKINS
+2 IF AIBOL(0)=AIBE
SET AIBOT=AIBOT_X
GOTO CKINS
MOVOVFL ;ADD FIELD TO OVERFLOW RECORD
+1 IF AIBE-AIBOL(0)>AIBOL(1)
GOTO MOVOVF2
+2 SET AIBOT(1)=$EXTRACT(AIBOT(1),1,AIBE-AIBOL(0))_X_$EXTRACT(AIBOT(1),AIBB-AIBOL(0)+AIBL-1,255)
GOTO CKINS
MOVOVF2 ;
+1 IF AIBE-AIBOL(0)<AIBOL
GOTO MOVOVF3
+2 SET AIBOT(1)=AIBOT(1)_$JUSTIFY("",AIBB-AIBOL(0)-$LENGTH(AIBOT(1))-1)_X
GOTO CKINS
MOVOVF3 ;
+1 IF AIBOL=AIBE
SET AIBOT(1)=AIBOT(1)_X
GOTO CKINS
CKINS ;CHECK IF PIECE IS TO TO INSERTED INTO NODE
+1 IF AIBG="I"
GOTO INSPIECE
GOTO RETURN
INSPIECE ;INSERT MISSING PIECE IN INPUT NODE
+1 SET AIBI(0)=0
FOR AIBI3=1:1:AIBI
SET AIBI(0)=AIBI(0)+$LENGTH($PIECE(AIBIN,U,AIBI3))
+2 SET AIBIN=$EXTRACT(AIBIN,1,AIBI(0))_U_$EXTRACT(AIBIN,AIBI(0)+1,999)
GOTO RETURN
WRITE ;WRITE ABILITY FOR REGISTRATION HEADER RECORD
+1 SET AIBH2=X_$JUSTIFY("",14-$LENGTH(X))
SET AIBOT=AIBH1_AIBH2_AIBH3
+2 IF AIBGBLP="AGHA"
SET AIBOT=AIBOT_AIBH4
+3 IF '$TEST
SET AIBOT=AIBOT_AIBH5
+4 SET AIBOT=AIBOT_$JUSTIFY("",250-$LENGTH(AIBOT))
SET AIBOT(1)=$JUSTIFY("",60)
+5 SET AIBCTB=AIBCTB+1
DO ^AIBCVT3
RETURN ;RETURN TO CALLING ROUTINE
+1 SET AIBG=""
QUIT
