- 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
