Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ONCACD1

ONCACD1.m

Go to the documentation of this file.
  1. ONCACD1 ;HINES OIFO/GWB - Extract NAACCR/STATE/VACCR data ;09/06/11
  1. ;;2.2;ONCOLOGY;**1,4,5,8,9,13,14,15,17,18,20**;Jul 31, 2013;Build 5
  1. ;
  1. ;P5 added in RQRS the Analytic Cases selection.
  1. ;P8 allows BLANK in TNM Clin/Path data fields & others.
  1. ;P9 discard in State Extract - COC=34 & Analytic=NO
  1. EN1 ;Entry point
  1. K ^TMP($J)
  1. N EXPORT,PAGE,STOPDT,OIEN,ZTREQ
  1. ;P18
  1. I $D(EDT),($P(EDT,".",2))="" S EDT=EDT_.2500
  1. I $D(DATE1),($P(DATE1,".",2))="" S DATE1=DATE1_.2500
  1. S PAGE=1,OIEN=0
  1. S EXPORT="YES"
  1. D SETUP
  1. I 'DEVICE W $C(26) H 30
  1. Q
  1. ;
  1. SETUP ;Loop through appropriate cross-reference
  1. I 'DEVICE S X=0 X ^%ZOSF("RM") ;Disable autowrap
  1. N BLANK,DCLC,FDNUM,IEN,NC,NINE,TPG,ZERO,ZNINE,X
  1. S BLANK=" "
  1. S (IEN,ZERO)=0
  1. S NINE=9,ZNINE="09"
  1. S OUT=$G(OUT,0)
  1. ;P14
  1. N ONCX21,ONCDTNW,ONCDT,ONCPRNT,ONCIE160,ONCTZONE
  1. S ONCPRNT=0
  1. I ('DEVICE),((EXTRACT=3)!(EXTRACT=5)!(EXTRACT=6)!(EXTRACT=7)) D
  1. .N ONC11,ONC22,ONC33,ONC44,ONC55,ONCNN,ONCPP,ONCTT,ONCDTIME,ONCDIC,ONCTYPE,ONCXPRT,ONCTHR,ONCTMN,ONCTSN
  1. .S ONCT=$$NOW^XLFDT()
  1. .S ONCTZONE=$$TZ^XLFDT()
  1. .S ONCTHR=$E(ONCT,9,10),ONCTMN=$E(ONCT,11,12),ONCTSN=$E(ONCT,13,14)
  1. .S:ONCTSN="" ONCTSN="00"
  1. .S:($L(ONCTSN)=1) ONCTSN="0"_ONCTSN
  1. .S ONCTSN=ONCTSN_".000"_$E(ONCTZONE,1,3)_":"_$E(ONCTZONE,4,5)
  1. .S ONCDTNW=""""_(1700+$E(ONCT,1,3))_"-"_$E(ONCT,4,5)_"-"_$E(ONCT,6,7)_"T"_ONCTHR_":"_ONCTMN_":"_ONCTSN_""""
  1. .S ONCX21=1
  1. .S ONCTYPE="""A"""
  1. .I EXTRACT=7 S ONCTYPE="""I"""
  1. .S ONCDIC="""http://naaccr.org/naaccrxml/naaccr-dictionary-230.xml"""
  1. .S ONC11=" baseDictionaryUri="
  1. .S ONC22=" recordType=",ONC33=" timeGenerated=",ONC44=" specificationVersion="
  1. .W "<?xml version=""1.0"" encoding=""UTF-8""?>",!
  1. .W "<NaaccrData xmlns=""http://naaccr.org/naaccrxml""",ONC11,ONCDIC,!
  1. .W ONC22,ONCTYPE,ONC33,ONCDTNW,ONC44,"""1.4""",">"
  1. .S ONCXPRT=1
  1. ;
  1. ;NCDB EXTRACT
  1. ;Loop through DATE DX (165.5,3) "ADX" cross-reference
  1. S ONCDT=DATE
  1. I STEXT=0 F S ONCDT=$O(^ONCO(165.5,"ADX",ONCDT)) Q:(ONCDT>DATE1)!(ONCDT="") S IEN=0 F S IEN=$O(^ONCO(165.5,"ADX",ONCDT,IEN)) Q:IEN="" I $$DIV^ONCFUNC(IEN)=DUZ(2) D Q:OUT
  1. .I $G(NCDB)=2 S DCLC=$P($G(^ONCO(165.5,IEN,7)),U,21) Q:(DCLC<SDT)!(DCLC>EDT)
  1. .I $G(NCDB)=3 S ACCN=$P($G(^ONCO(165.5,IEN,0)),U,5) Q:(ACCN<SDT)!(ACCN>EDT)
  1. .D LOOP
  1. ;
  1. ;VACCR/STATE EXTRACT
  1. ;Loop through DATE CASE COMPLETED (165.5,90) "AAD" cross-reference
  1. I ($G(STEXT)=1),($G(ONCLDT)=1) S SDT=SDT-.00001 F S SDT=$O(^ONCO(165.5,"AAD",SDT)) Q:(SDT<1)!(SDT>EDT)!(OUT=1) F S IEN=$O(^ONCO(165.5,"AAD",SDT,IEN)) Q:IEN<1 I $$DIV^ONCFUNC(IEN)=DUZ(2) D Q:OUT
  1. .Q:$G(^ONCO(165.5,IEN,0))=""
  1. .D LOOP
  1. ;Loop through DATE CASE LAST CHANGED (165.5,198) "AAE" cross-reference
  1. I ($G(STEXT)=1),($G(ONCLDT)=2) S SDT=SDT-.00001 F S SDT=$O(^ONCO(165.5,"AAE",SDT)) Q:(SDT<1)!(SDT>EDT)!(OUT=1) F S IEN=$O(^ONCO(165.5,"AAE",SDT,IEN)) Q:IEN<1 I $$DIV^ONCFUNC(IEN)=DUZ(2) D Q:OUT
  1. .Q:$G(^ONCO(165.5,IEN,0))=""
  1. .D LOOP
  1. ;Loop through ACCESSION NUMBER (165.5,.05) "AA" cross-reference
  1. I ($G(STEXT)=1),($G(ONCLDT)=3) S SDT=SDT-1 F S SDT=$O(^ONCO(165.5,"AA",SDT)) Q:(SDT<1)!(SDT>EDT)!(OUT=1) F S IEN=$O(^ONCO(165.5,"AA",SDT,IEN)) Q:IEN<1 I $$DIV^ONCFUNC(IEN)=DUZ(2) D Q:OUT
  1. .Q:$G(^ONCO(165.5,IEN,0))=""
  1. .D LOOP
  1. ;
  1. ;VACCR/STATE EXTRACT
  1. ;Loop through DATE CASE LAST CHANGED (165.5,198) "AAE" cross-reference
  1. I ($G(STEXT)=2) S SDT=SDT-1 F S SDT=$O(^ONCO(165.5,"AAE",SDT)) Q:(SDT<1)!(SDT>EDT)!(OUT=1) F S IEN=$O(^ONCO(165.5,"AAE",SDT,IEN)) Q:IEN<1 I $$DIV^ONCFUNC(IEN)=DUZ(2) D Q:OUT
  1. .Q:$G(^ONCO(165.5,IEN,0))=""
  1. .D LOOP
  1. ;
  1. ;RQRS EXTRACT
  1. ;Loop through DATE DX (165.5,3) "ADX" cross-reference
  1. I ($G(STEXT)=3),($G(ONCLDT)=1) S SDT=SDT-1 F S SDT=$O(^ONCO(165.5,"ADX",SDT)) Q:(SDT<1)!(SDT>EDT)!(OUT=1) F S IEN=$O(^ONCO(165.5,"ADX",SDT,IEN)) Q:IEN<1 I $$DIV^ONCFUNC(IEN)=DUZ(2) D Q:OUT
  1. .Q:$G(^ONCO(165.5,IEN,0))=""
  1. .S TPG=$P($G(^ONCO(165.5,IEN,2)),U,1)
  1. .S NC=0
  1. .F FDNUM=.03,.05,.06,3,20,22.3 I $$GET1^DIQ(165.5,IEN,FDNUM,"I")="" S NC=1
  1. .Q:NC=1
  1. .S ONCCLCA=$E($$GET1^DIQ(165.5,IEN,.04),1,2)
  1. .I ($G(ONCR12)=2),(ONCCLCA<23) D LOOP Q
  1. .I ($G(ONCR12)=1),(($E(TPG,3,4)=50)!($E(TPG,3,4)=18)!($E(TPG,3,4)=20))&(TPG'=67181) D LOOP ; screen out 67181 (appendix) cases - p2.2*4
  1. ;
  1. ;Loop through DATE CASE LAST CHANGED (165.5,198) "AAE" cross-reference
  1. ;Quit if "ADX" is before 2008 - p2.2*4
  1. I ($G(STEXT)=3),($G(ONCLDT)=2) S SDT=SDT-.00001 F S SDT=$O(^ONCO(165.5,"AAE",SDT)) Q:(SDT<1)!(SDT>EDT)!(OUT=1) F S IEN=$O(^ONCO(165.5,"AAE",SDT,IEN)) Q:IEN<1 I $$DIV^ONCFUNC(IEN)=DUZ(2) D Q:OUT
  1. .Q:$G(^ONCO(165.5,IEN,0))=""
  1. .Q:$P($G(^ONCO(165.5,IEN,0)),U,16)<3060101
  1. .S TPG=$P($G(^ONCO(165.5,IEN,2)),U,1)
  1. .S NC=0
  1. .F FDNUM=.03,.05,.06,3,20,22.3 I $$GET1^DIQ(165.5,IEN,FDNUM,"I")="" S NC=1
  1. .Q:NC=1
  1. .S ONCCLCA=$E($$GET1^DIQ(165.5,IEN,.04),1,2)
  1. .I ($G(ONCR12)=2),(ONCCLCA<23) D LOOP Q
  1. .I ($G(ONCR12)=1),($E(TPG,3,4)=50)!($E(TPG,3,4)=18)!($E(TPG,3,4)=20)&(TPG'=67181) D LOOP
  1. ;
  1. ;Loop through ACCESSION NUMBER (165.5,.05) "AA" cross-reference
  1. I ($G(STEXT)=3),($G(ONCLDT)=3) S SDT=SDT-1 F S SDT=$O(^ONCO(165.5,"AA",SDT)) Q:(SDT<1)!(SDT>EDT)!(OUT=1) F S IEN=$O(^ONCO(165.5,"AA",SDT,IEN)) Q:IEN<1 I $$DIV^ONCFUNC(IEN)=DUZ(2) D Q:OUT
  1. .Q:$G(^ONCO(165.5,IEN,0))=""
  1. .Q:$P($G(^ONCO(165.5,IEN,0)),U,16)<3060101
  1. .S TPG=$P($G(^ONCO(165.5,IEN,2)),U,1)
  1. .S NC=0
  1. .F FDNUM=.03,.05,.06,3,20,22.3 I $$GET1^DIQ(165.5,IEN,FDNUM,"I")="" S NC=1
  1. .Q:NC=1
  1. .S ONCCLCA=$E($$GET1^DIQ(165.5,IEN,.04),1,2)
  1. .I ($G(ONCR12)=2),(ONCCLCA<23) D LOOP Q
  1. .I ($G(ONCR12)=1),($E(TPG,3,4)=50)!($E(TPG,3,4)=18)!($E(TPG,3,4)=20)&(TPG'=67181) D LOOP
  1. I ('DEVICE),$G(ONCPRNT)>20,((EXTRACT=3)!(EXTRACT=5)!(EXTRACT=6)!(EXTRACT=7)) D
  1. .W !,?5,"</Tumor>"
  1. .W !,?3,"</Patient>"
  1. .W !,"</NaaccrData>",!
  1. Q
  1. ;
  1. LOOP ;Apply extract selection rules
  1. ;P#9
  1. ;P#13
  1. Q:OUT
  1. I ($G(EXTRACT)=2)!($G(EXTRACT)=5),($E($$GET1^DIQ(165.5,IEN,.04),1,2)=34),($G(ACO)=0) Q
  1. N LINE,RULES,VALID,JUMP
  1. S RULES=0
  1. F S RULES=$O(^ONCO(160.16,EXTRACT,"RULES",RULES)) Q:RULES<1 D
  1. .S LINE=^ONCO(160.16,EXTRACT,"RULES",RULES,0)
  1. .X LINE
  1. Q:'VALID
  1. S ^TMP($J,IEN)=""
  1. D OUTPUT(IEN,EXTRACT,JUMP,.OUT)
  1. ;I 'DEVICE W !
  1. Q
  1. ;
  1. OUTPUT(IEN,EXTRACT,JUMP,OUT) ;Output
  1. S ACD160=$P(^ONCO(165.5,IEN,0),U,2)
  1. I DEVICE D HEAD(IEN,.OUT) Q:OUT
  1. N POS S POS=0
  1. ;P14 xml format
  1. I $G(ONCX21)=1 D Q
  1. .Q:$D(ONCIE160(IEN))
  1. .W:$G(ONCPRNT)>20 !,?5,"</Tumor>"
  1. .W:$G(ONCPRNT)>20 !,?3,"</Patient>"
  1. .D XML21
  1. .;S ONCPRNT=1
  1. .S ONCXPRT=1
  1. .Q
  1. F S POS=$O(^ONCO(160.16,EXTRACT,"FIELD","B",POS)) Q:POS<1 D Q:OUT
  1. .N NODE S NODE=0
  1. .F S NODE=$O(^ONCO(160.16,EXTRACT,"FIELD","B",POS,NODE)) Q:NODE<1 D Q:OUT
  1. ..N STRING,DEFAULT,FILL,LEN
  1. ..Q:$G(^ONCO(160.16,EXTRACT,"FIELD",NODE,0))=""
  1. ..D DISPLAY(DEVICE,$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,0),U,1)_U_$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,0),U,4),.OUT)
  1. ..Q:OUT
  1. ..S LEN=$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,0),U,2)
  1. ..S STRING=$TR(^ONCO(160.16,EXTRACT,"FIELD",NODE,1),"~","^")
  1. ..S DEFAULT=$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,2),U,1)
  1. ..S FILL=$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,3),U,1)
  1. ..D DATA(IEN,ACD160,STRING,DEFAULT,FILL,LEN,JUMP,NODE,POS)
  1. ..;=========================================================
  1. ..; This Code supports the PCE Extracts (currently disabled)
  1. ..;=========================================================
  1. ..I $G(^ONCO(160.16,EXTRACT,0))["ZZNCDB" D
  1. ...I $O(^ONCO(160.16,EXTRACT,"FIELD","B",POS))>1 Q ;QUIT if not end
  1. ...N EXTRACT,NODE,POS
  1. ...S EXTRACT=100,JUMP=0
  1. ...;S:$D(^ONCO(165.5,"APCE","BLA",IEN)) EXTRACT=1
  1. ...; ^==== Bladder 95,90,85
  1. ...;S:$D(^ONCO(165.5,"APCE","THY",IEN)) EXTRACT=2
  1. ...; ^==== Thyroid 96,91,86
  1. ...;S:$D(^ONCO(165.5,"APCE","STS",IEN)) EXTRACT=3
  1. ...; ^==== Soft Tissue 96,91,86
  1. ...;S:$D(^ONCO(165.5,"APCE","COL",IEN)) EXTRACT=4
  1. ...; ^==== Colorectal 97,92,87
  1. ...;S:$D(^ONCO(165.5,"APCE","NHL",IEN)) EXTRACT=5
  1. ...; ^==== Non-Hodgkins 97,92,87
  1. ...;S:$D(^ONCO(165.5,"APCE","BRE",IEN)) EXTRACT=6
  1. ...; ^==== Breast 98,93,88
  1. ...;S:$D(^ONCO(165.5,"APCE","PRO2",IEN)) EXTRACT=7
  1. ...; ^==== Prostate 98,93,88
  1. ...;S:$D(^ONCO(165.5,"APCE","MEL",IEN)) EXTRACT=8
  1. ...; ^==== Melanoma 99,94,89
  1. ...;S:$D(^ONCO(165.5,"APCE","HEP",IEN)) EXTRACT=9
  1. ...; ^==== Hepatocellular Cancers 00,95,90
  1. ...;S:$D(^ONCO(165.5,"APCE","CNS",IEN)) EXTRACT=10
  1. ...; ^==== Primary Intracranial/CNS Tumors 00,95,90
  1. ...;S:$D(^ONCO(165.5,"APCE","LNG",IEN)) EXTRACT=11
  1. ...; ^==== Lung (NSCLC) 01,96,91
  1. ...;S:$D(^ONCO(165.5,"APCE","GAS",IEN)) EXTRACT=12
  1. ...; ^==== Gastric Cancers 01,96,91
  1. ...S POS=0
  1. ...F S POS=$O(^ONCO(160.17,EXTRACT,"FIELD","B",POS)) Q:POS<1 D Q:OUT
  1. ....N NODE S NODE=0
  1. ....F S NODE=$O(^ONCO(160.17,EXTRACT,"FIELD","B",POS,NODE)) Q:NODE<1 D Q:OUT
  1. .....N DEFAULT,FILL,LEN,STRING
  1. .....Q:$G(^ONCO(160.17,EXTRACT,"FIELD",NODE,0))=""
  1. .....D DISPLAY(DEVICE,$P(^ONCO(160.17,EXTRACT,"FIELD",NODE,0),U,1)_U_$P(^ONCO(160.17,EXTRACT,"FIELD",NODE,0),U,4),.OUT)
  1. .....Q:OUT
  1. .....S STRING=$TR(^ONCO(160.17,EXTRACT,"FIELD",NODE,1),"~","^")
  1. .....S DEFAULT=^ONCO(160.17,EXTRACT,"FIELD",NODE,2)
  1. .....S FILL=^ONCO(160.17,EXTRACT,"FIELD",NODE,3)
  1. .....S LEN=$P(^ONCO(160.17,EXTRACT,"FIELD",NODE,0),U,2)
  1. .....D DATA(IEN,ACD160,STRING,DEFAULT,FILL,LEN,JUMP,NODE,POS)
  1. Q
  1. ;
  1. N FLG
  1. I IEN=OIEN S FLG=0
  1. I IEN'=OIEN S OIEN=IEN,FLG=1
  1. I 'FLG Q:$Y+4<IOSL
  1. I PAGE'=1 D Q:OUT
  1. .Q:$E(IOST,1,2)'="C-"
  1. .N DIR,Y
  1. .S DIR(0)="E" D ^DIR
  1. .I 'Y S OUT=1 Q
  1. D HEADER
  1. Q
  1. ;
  1. I PAGE'=1 W @IOF
  1. I PAGE=1,$E(IOST,1,2)="C-" W @IOF
  1. I STEXT=3 W !,"RCRS EXTRACT",?70,"Page: ",PAGE S PAGE=PAGE+1
  1. E W !,$P(^ONCO(160.16,EXTRACT,0),U),?70,"Page: ",PAGE S PAGE=PAGE+1
  1. W !,"Patient: ",$$GET1^DIQ(160,ACD160,.01,"E")
  1. W ?55,"SSN: ",$$GET1^DIQ(160,ACD160,2,"E")
  1. W !,"Col#",?5,"Item name",?51,"Value",!
  1. F I=1:1:79 W "="
  1. Q
  1. XML21 ;P14
  1. N ONCRTYP,ONCOLD,ONCPOS
  1. S ONCOLD="TEST",(ONCPOS,POS)="A",ONCRTYP=""
  1. S ONCIE160(IEN)=IEN
  1. F S POS=$O(^ONCO(160.16,EXTRACT,"FIELD","D",POS)) Q:POS="" D Q:OUT
  1. .N NODE,ONCXDATA S NODE=0
  1. .;I POS="N" S ONCRTYP="<NaaccrData>"
  1. .I POS="P" S ONCRTYP="<Patient>"
  1. .I POS="T" S ONCRTYP="<Tumor>"
  1. .F S NODE=$O(^ONCO(160.16,EXTRACT,"FIELD","D",POS,NODE)) Q:NODE<1 D Q:OUT
  1. ..N STRING,DEFAULT,FILL,LEN,ONCXDATA
  1. ..Q:$G(^ONCO(160.16,EXTRACT,"FIELD",NODE,0))=""
  1. ..S ONCXDATA=$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,0),U,5)
  1. ..Q:ONCXDATA=""
  1. ..I (POS'=ONCPOS),(ONCOLD'=ONCRTYP),(ONCRTYP'="") D
  1. ...W:POS="P" !,?3,ONCRTYP
  1. ...W:POS="T" !,?5,ONCRTYP
  1. ...S ONCOLD=ONCRTYP,ONCPOS=POS
  1. ..;D DISPLAY(DEVICE,$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,0),U,1)_U_$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,0),U,4),.OUT)
  1. ..;Q:OUT
  1. ..S LEN=$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,0),U,2)
  1. ..S STRING=$TR(^ONCO(160.16,EXTRACT,"FIELD",NODE,1),"~","^")
  1. ..S DEFAULT=$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,2),U,1)
  1. ..S FILL=$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,3),U,1)
  1. ..D DATA(IEN,ACD160,STRING,DEFAULT,FILL,LEN,JUMP,NODE,POS)
  1. .S ONCXPRT=1
  1. Q
  1. ;
  1. DISPLAY(DEVICE,WRITE,OUT) ; Display preview
  1. Q:'DEVICE
  1. N DOTS,COL,ITEM
  1. I DEVICE,($Y+5)>IOSL D HEAD(0,.OUT) Q:OUT
  1. S COL=$P(WRITE,U,1)
  1. S COL=$S($L(COL)=1:" "_COL,$L(COL)=2:" "_COL,$L(COL)=3:" "_COL,1:COL)
  1. S ITEM=$P(WRITE,U,2),ITEM=$E(ITEM,1,45)
  1. S DOTS=(46-$L(ITEM))
  1. W !,COL,?5,ITEM
  1. F I=1:1:DOTS W "."
  1. Q
  1. ;
  1. DATA(IEN,ACD160,STRING,DEFAULT,FILL,LEN,JUMP,NODE,POS) ;Compute extract value
  1. N ACDANS,EXIT S EXIT=0
  1. I $G(ONCX21)=1 D Q
  1. .I $G(ONCPRNT)>20,(POS="N") Q
  1. .X STRING
  1. .;If value = "", extract DEFAULT value
  1. .I (ACDANS=""),(DEFAULT="BLANK") Q
  1. .N I,X S X=""
  1. .I DEFAULT=8 D
  1. ..F I=1:1:LEN S ACDANS=ACDANS_@DEFAULT
  1. .I @DEFAULT="09" S ACDANS=@DEFAULT
  1. .;F I=1:1:LEN S ACDANS=ACDANS_@DEFAULT
  1. .I (ACDANS["&")!(ACDANS["<")!(ACDANS[">") D STRIP
  1. .D XFILL
  1. .I ('DEVICE),(ACDANS=""),((EXTRACT=3)!(EXTRACT=5)!(EXTRACT=6)!(EXTRACT=7)) Q
  1. .W:POS="N" !,?2
  1. .W:POS="P" !,?5
  1. .W:POS="T" !,?7
  1. .W "<Item naaccrId=""",ONCXDATA,""">",ACDANS,"</Item>"
  1. .S ONCPRNT=ONCPRNT+1
  1. .Q
  1. I JUMP'="0" D
  1. .I POS<$P(JUMP,U) Q
  1. .I POS>$P(JUMP,U,2) Q
  1. .N I
  1. .S EXIT=1
  1. .F I=1:1:LEN W BLANK
  1. Q:EXIT
  1. X STRING
  1. ;
  1. ;If value = "", extract DEFAULT value
  1. I ACDANS="" D Q
  1. .N I,X S X=""
  1. .I DEFAULT=8 D Q
  1. ..F I=1:1:LEN W DEFAULT
  1. .I @DEFAULT="09" W @DEFAULT Q
  1. .F I=1:1:LEN W @DEFAULT
  1. ;
  1. ;If value too long, truncate to LENGTH (160.161,1)
  1. ;If value too short, pad with FILL (160.161,6)
  1. I $L(ACDANS)=LEN W ACDANS Q
  1. I $L(ACDANS)>LEN W $E(ACDANS,1,LEN) Q
  1. E D Q
  1. .N JUST,STUFF,I,REM,CAL
  1. .S JUST=$P(FILL,","),STUFF=$P(FILL,",",2)
  1. .S REM=LEN-$L(ACDANS)
  1. .I JUST="R" W ACDANS
  1. .F I=1:1:REM W @STUFF
  1. .I JUST="L" W ACDANS
  1. Q
  1. XFILL ;Truncate or pad xml fields
  1. I $L(ACDANS)=LEN Q
  1. I $L(ACDANS)>LEN S ACDANS=$E(ACDANS,1,LEN) Q
  1. E D Q
  1. .N JUST,STUFF,I,REM,CAL,LACDANS
  1. .S LACDANS=""
  1. .S JUST=$P(FILL,","),STUFF=$P(FILL,",",2),STUFF=$P(STUFF,"^")
  1. .Q:STUFF="BLANK"
  1. .S:STUFF="ZERO" STUFF=0
  1. .S:STUFF="NINE" STUFF=9
  1. .S REM=LEN-$L(ACDANS)
  1. .F I=1:1:REM S:JUST="R" ACDANS=ACDANS_STUFF S:JUST="L" LACDANS=LACDANS_STUFF
  1. .I JUST="L" S ACDANS=LACDANS_ACDANS
  1. Q
  1. STRIP ;replace special characters
  1. N AA,BB,X1
  1. S BB=""
  1. F I=1:1:($L(ACDANS)) Q:I'>0 D
  1. .S (AA,X1)=$E(ACDANS,I)
  1. .S:X1="&" AA=" and "
  1. .S:X1=">" AA=" GT "
  1. .S:X1="<" AA=" LT "
  1. .S:X1="$" AA=" "
  1. .S BB=BB_AA
  1. S ACDANS=BB
  1. Q
  1. RCRS ;RCRS exeption rules
  1. I ($P(TPG,3,4)=44),((MPGH>79999)&(MPGH<81109)) S VALID=0
  1. I (MPGH=80772),(($P(TPG,3,5)=619)!($P(TPG,3,5)=529)) S VALID=0
  1. I (MPGH=80772),(($P(TPG,3,4)=51)!($P(TPG,3,4)=21)!$P(TPG,3,4)=32) S VALID=0
  1. I (DATEDX>3220000),(($P(TPG,3,5)>159)&($P(TPG,3,5)<167)),((MPGH=82112)!(MPGHD=82612)!(MPGH=82632)) S VALID=0
  1. I (DATEDX>3220000),(($P(TPG,3,5)>167)&($P(TPG,3,5)<174)),((MPGH=82112)!(MPGHD=82612)!(MPGH=82632)) S VALID=0
  1. I (DATEDX>3220000),(($P(TPG,3,5)>177)&($P(TPG,3,5)<180)),((MPGH=82112)!(MPGHD=82612)!(MPGH=82632)) S VALID=0
  1. I (DATEDX>3220000),($P(TPG,3,5)=53),((MPGH=84832)!(MPGHD=84842)) S VALID=0
  1. Q
  1. ;
  1. CLEANUP ;Cleanup
  1. K DATE,EDT,NCDB,SDT,STEXT