Routine: REGCONVT

REGCONVT ;CONVERT REG DATA TO TAPE [ 08/26/87  8:14 AM ]

 ;MODIFIED TO PROCESS MULTIPLE HEADERS ON DELETE RECORDS RFD&WLC 4-28-87

 ;TJF/DPSC

 R !!,"ENTER PRINTER PORT, NULL = 70 ",PR S:PR="" PR=70

 K DISP,OSET,FLIP,GDREC,FACNUM,FACCODE,FACNAME,^REGRG3

 S BLKS="",HR="",CNTIN=0,RG3=0,CNTOUT=0,CNTERR=0,X="",Z=""

 S RG12=0,FACSAVE="",FACSEQ="0001",ZR="000000"

 F I=1:1:254 S BLKS=BLKS_" "

 S %DT="",X="T" D ^%DT S DATE=Y

 W !!,"MOUNT 1600 BPI TAPE ON DEVICE 48"

 R !!,"REPLY ANY CHARACTER TO CONTINUE ",ANS#1

RGBL S GBL="AGTXDATA"

 S GBLPTT="^"_GBL I '$D(@GBLPTT) W !,"GLOBAL 'AGTXDATA' DOES NOT EXIST, JOB TERMINATED" Q

 S GBLPT="^"_GBL_"(Z)"

SETTIME S STRTTIME=$H

 S Z=$O(@GBLPT) S INPUT=@GBLPT I INPUT["RG1" W !!,"HEADER RECORD MISSING, RUN TERMINATED" Q

 S FACCODE=$P(INPUT,"^",1),FACNAME=$P(INPUT,"^",2)

 S FACSAVE=FACCODE

 S Z=$O(@GBLPT) S INPUT=@GBLPT_"^",AGN=""

 I Z="" W !!,"NO DATA IN GLOBAL, RUN TERMINATED" Q

 I $E(INPUT,1,3)="RG3" G KFLIP

 I $E(INPUT,1,3)'="RG1" W !!,"FIRST RECORD INVALID, RUN TERMINATED" Q

KFLIP ;

 K FLIP

OPNTAPE O 48:("EFU":176:310):3 E  U 0 W !,"TAPE UNIT 48 NOT ON-LINE, READY DEVICE" Q

 U 48 W *5

 S %ZA=$ZA,%ZA=%ZA\4#2 I %ZA=1 U 0 W !!,"TAPE UNIT 48 NEEDS WRITE RING, JOB ABORTED" Q

 D INT^%D

 O PR U PR W #,?10,"R E G I S T R A T I O N  C O N V E R S I O N  E R R O R  L I S T","    ",FACCODE,"  ",FACNAME,"    ",%DAT1

LPRC3 ;

 S FACNUM=$P(INPUT,"^",3) D FIXNUM

 I $E(INPUT,1,3)="RG3" S ^REGRG3(RG3)=INPUT S CNTIN=CNTIN+1,RG3=RG3+1 S Z=$O(@GBLPT) G:Z="" EOJ S INPUT=@GBLPT_"^"  G LPRC3

 G FLIPREC

FIXNUM S FL=6-$L(FACNUM)

 S FACNUM=$E(ZR,1,FL)_FACNUM

READ S Z=$O(@GBLPT) G:Z="" EOJ S HOLD=@GBLPT S INPUT="",AGN=""

 S INPUT=HOLD

 F J=1:1:$L(INPUT) I $E(INPUT,J)?1L S INPUT=$E(INPUT,1,J-1)_$C($A($E(INPUT,J))-32)_$E(INPUT,J+1,$L(INPUT))

 I $E(INPUT,1,3)="RG3" S ^REGRG3(RG3)=INPUT S CNTIN=CNTIN+1,RG3=RG3+1 G READ

 I $D(FLIP) I $E(INPUT,1,3)="RG1" S FACNUM=$P(INPUT,"^",3) D FIXNUM K FLIP,GDREC G FLIPREC

 I $E(INPUT,1,3)="RG2" S FLIP="" G FLIPREC

WERR W !!,"RECORD SECUENCE ERROR, RECORD COUNT IS ",CNTIN," DATA RECORD IS ",!!,INPUT G READ

FLIPREC I $E(INPUT,1,3)="RG1" S DISP=0,OSET=0,OUTPUT=FACSEQ

 E  I $E(INPUT,1,3)="RG2" S DISP=20,OSET=176,OUTPUT=""

 E  W !!,"RECORD CODE INVALID, VALUE FOUND IS ",INPUT W !!,"RUN TERMINATED" Q

 S CNTIN=CNTIN+1

 S I=0

LOOKUP S I=I+1 S X=$P(INPUT,"^",I+1) G:$P($T(TABLE+DISP+I),";",5)["SUB" HOLD G:$P($T(TABLE+DISP+I),";",5)["END" EOD

 I $P($T(TABLE+DISP+I),";",7)="S1" S HD="" S FL=6-$L(X) S HD=$E(ZR,1,FL)_X S X=HD,$P(INPUT,"^",I+1)=HD

 I $P($T(TABLE+DISP+I),";",7)="S2" I $P(INPUT,"^",I+1)'="" I $P(INPUT,"^",I+2)="" W !!,FACNUM," MAILING ADDRESS STREET EXISTS, MAILING ADDRESS TOWN MUST EXIST",!,"DATA RECORD IS ",INPUT

 I $P($T(TABLE+DISP+I),";",7)="S3" I $P(INPUT,"^",I+1)'="" I $P(INPUT,"^",I+2)="" W !!,FACNUM," MAILING ADDRESS TOWN EXISTS, MAILING ADDRESS STATE MUST EXIST",!,"DATA RECORD IS ",INPUT

 I $L(X)>$P($T(TABLE+DISP+I),";",4) W !!,"WARNING - ",$P($T(TABLE+DISP+I),";",5)," IS TRUNCATED TO ",$P($T(TABLE+DISP+I),";",4)," POSITIONS, VALUE BEFORE TRUNCATION IS '",X,"'",!,INPUT D SKPIT G:AGN="X" READ G BYPSS

 E  S OUTPUT=OUTPUT_$P(INPUT,"^",I+1)

BYPSS ;

 S OUTPUT=OUTPUT_$E(BLKS,1,($P($T(TABLE+DISP+I+1),";",3)-OSET)-$L(OUTPUT)-1)

 G LOOKUP

HOLD S SOUTPUT=OUTPUT S GDREC="" U PR G READ

EOD I $D(GDREC) D

 .I FACSAVE'=$E(SOUTPUT,5,10) S FACSAVE=$E(SOUTPUT,5,10),FACSEQ=FACSEQ+1

 . S:FACSEQ>9999 FACSEQ="0001"

 .S RG12=RG12+1,CNTOUT=CNTOUT+1 U 48 W SOUTPUT,OUTPUT U 0 W !,CNTOUT U PR

 .S FL=4-$L(FACSEQ),FACSEQ=$E(ZR,1,FL)_FACSEQ

 K GDREC G READ

EOJ ;END OF JOB PROCESSING

 U 48 C 48

I I '$D(^REGRG3) U PR W !!,"NO RG3 RECORDS PRESENT" G FINISH

ROPN ;

 O 48:("EFU":80:80):3 E  U 0 W !!,"TAPE UNIT 48 NOT READY, ANY KEY TO CONTINUE ",ANS#1 G ROPN

BLDHDR S OUTPUT="",X="" U 48 W *1 ; BACKSPACE OVER LAST TAPE MARK

 ;DSM WRITES 2 TAPE MARKS AT CLOSE THEN BACKS UP 1 TAPE

 ;MARK.  THE NEXT COMMAND W *1 BACKS UP OVER THE 1ST TAPE

 ;MARK

READRG3 S X=$O(^REGRG3(X)) G:X="" FINISH S DATA=^REGRG3(X)

 U 48

RFD1 I X>1 G:$P(DATA,"^",2)=$P(^REGRG3(X-1),"^",2) SETPTID

 S HR=""

 I HR="" S HR="X",OUTPUT="|"_"|"_"|"_$E($P(DATA,"^",2),1,2)_$E($P(DATA,"^",2),1,6)_$E($P(DATA,"^",2),1,6)_"RRD01   "_$E(DATE,4,7)_$E(DATE,2,3)_"   DELETE RECORDS REGISTRATION"_$E(BLKS,1,19) S CNTOUT=CNTOUT+1 W OUTPUT

SETPTID S HD="",FL=6-$L($P(DATA,"^",3)),HD=$E(ZR,1,FL)_$P(DATA,"^",3),$P(DATA,"^",3)=HD

SETMGID S HD1="",FL=6-$L($P(DATA,"^",4)),HD1=$E(ZR,1,FL)_$P(DATA,"^",4)

 U PR

 I $L($P(DATA,"^",5))>2 W !!,$P(DATA,"^",2)," ",$P($T(RG3DESC+1),";",3),!,DATA S CMTERR=CNTERR+1 G READRG3

 I $L($P(DATA,"^",6))>1 W !!,$P(DATA,"^",2)," ",$P($T(RG3DESC+2),";",3),!,DATA S CNTERR=CNTERR+1 G READRG3

 I $L($P(DATA,"^",3))>6 W !!,$P(DATA,"^",2)," ",$P($T(RG3DESC+3),";",3),!,DATA S CNTERR=CNTERR+1 G READRG3

 U 48

BLDDTL S OUTPUT="?"_$P(DATA,"^",5)_$P(DATA,"^",6)_"RRR"_$P(DATA,"^",3)_"99R"_$E(DATE,2,7)_"***         2"_$E($P(DATA,"^",2),5,6)_$E(BLKS,1,43) D:HD1'=ZR BLDMRGID S CNTOUT=CNTOUT+1 W OUTPUT

 G READRG3

BLDMRGID ;SET MERGE ID IN OUTPUT RECORD

 S OUTPUT=$E(OUTPUT,1,25)_"RRR"_HD1_$E(OUTPUT,35,80)

FINISH ;

 S T=$P($H,",",2)-$P(STRTTIME,",",2)

 S S=T#60

 S X=T\60

 S H=X\60

 S M=X#60

 U 0 W !!,"RUN TIME ",H," ",M," ",S

LASTOUT ;

 U PR

 W !,"RECORDS INPUT     ",CNTIN

 W !,"RECORDS OUTPUT    ",CNTOUT

 W !,"RECORDS REJECTED  ",CNTERR

 W !!,"TOTAL (RG1/RG2) RECORDS ",RG12

 W !!,"TOTAL (RG3) RECORDS     ",RG3

 S RG12=RG12+RG3

 W !!,"TOTAL RECORDS TO BE ENTERED"

 W !,"INTO PCIS LOGBOOK    ",RG12

 W #,#

 I $D(^REGRG3) U 48 W *3 W *5 C 48

U 0

 W !!,"RECORDS INPUT     ",CNTIN

 W !,"RECORDS OUTPUT    ",CNTOUT

 W !,"RECORDS REJECTED  ",CNTERR

 W !,"DELETE/MERGE RECORDS  ",RG3

 W !!,"TOTHE DELETE/MERGE PROCESS WILL CREATE MULTIPLE HEADERS AS FACILITIES CHANGE"

 W !!,"TOTAL RECORDS (RG1/RG2) AND RG3 ",RG12,", SHOULD EQUAL AREA COUNT"

 W !!,"END OF PROCESSING" C PR Q

SKPIT I $P($T(TABLE+DISP+1),";",6) S CNTERR=CNTERR+1,AGN="X"

 E  S OUTPUT=OUTPUT_$E($P(INPUT,"^",I+1),1,$P($T(TABLE+DISP+I),";",4))

TABLE ;1ST FIELD IS POSITION IN OUTPUT RECORD 2ND IS INPUT FIELD LENGTH

RG1DESC ;;005;06;FACILITY CODE

 ;;011;06;UNIT RECORD NUMBER;;S1

 ;;017;20;LAST NAME;X

 ;;037;11;FIRST NAME;X

 ;;048;11;MIDDLE NAME;X

 ;;059;02;CLASSIFICATION CODE

 ;;061;07;DATE OF BIRTH

 ;;068;01;SEX

 ;;069;09;SOCIAL SECURITY NUMBER

 ;;078;03;TRIBE CODE

 ;;081;01;BLOOD QUANTUM

 ;;082;20;FATHER LAST NAME;X

 ;;102;11;FATHER FIRST NAME;X

 ;;113;01;FATHER MIDDLE INITIAL

 ;;114;07;COMMUNITY OF RESIDENCE

 ;;121;30;MAILING ADDRESS STREET;X;S2

 ;;151;15;MAILING ADDRESS TOWN;X;S3

 ;;166;02;MAILING ADDRESS STATE

 ;;168;09;MAILING ADDRESS ZIP

 ;;177;;END OF RG1 TABLESUB

RG2DESC ;;177;20;MOTHER NAME LAST;X

 ;;197;11;MOTHER NAME FIRST;X

 ;;208;01;MOTHER NAME MIDDLE INITIAL

 ;;209;06;DATE OF DEATH

 ;;215;01;MEDICARE A ELIGIBLE

 ;;216;14;MEDICARE A ENROLL NUMBER

 ;;225;01;MEDICARE A SUFFIX

 ;;230;06;MEDICARE A ELIGIBILTY

 ;;236;01;MEDCIARE B ELIGIBLE

 ;;237;14;MEDCIARE B ENROLL NUMBER

 ;;246;01;MEDCIARE B SUFFIX

 ;;251;06;MEDICARE B ELIGIBILITY

 ;;257;01;MEDICARE AB ELIGIBLE

 ;;258;14;MEDICARE AB ENROLL NUMBER

 ;;267;01;MEDICARE AB SUFFIX

 ;;272;06;MEDICARE AB ELIGIBILITY

 ;;278;01;MEDICAID ELIGIBLE

 ;;279;14;MEDICAID NUMBER

 ;;288;01;MEDICAID SUFFIX

 ;;293;06;MEDICAID ELIGIBILITY

 ;;299;01;VETERAN

 ;;300;01;BLUE CROSS ELIGIBALE

 ;;301;01;OTHER ELIGIBLE

 ;;302;01;CHS ELIGIBILITY

 ;;303;01;PATIENT SIGNED

 ;;304;01;ADD/MODIFY CODE

 ;;305;06;OPT/MM RELEASE DATE

 ;;311;;END OF RG2 TABLE

END ;END OF PROGRAM

RG3DESC ;;DELETE RECORD FORMAT

 ;;PIECE 5 IS INVALID - PATIENT INITIALS

 ;;PIECE 6 IS INVALID - PATIENT SEX

 ;;PIECE 3 IS INVALID - PATIENT ID

REGCONVT.m