©2011-2018 Open Source Electronic Health Record Alliance
This work is licensed under a Creative Commons Attribution 3.0 Unported License
This work is licensed under a Creative Commons Attribution 3.0 Unported License
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
Q
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)
Q
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))
Q
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