ONCRPC ;Hines OIFO/GWB - Extract VACCR data via ONC VACCR RPC ;09/22/11
;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
;;
EN1(RESULT,DATEUSED,START,END) ;Entry point
K ^TMP("ONCRPC")
N VERSION
S VERSION=$O(^ONCO(160.16,"B","VACCR EXTRACT"))
S EXTRACT=$O(^ONCO(160.16,"B",VERSION,0))
S OUT=0
S U="^"
D SETUP
S RESULT=$NA(^TMP("ONCRPC"))
Q
;
SETUP ;Loop through appropriate cross-reference
N BLANK,DCLC,FDNUM,IEN,NC,NINE,TPG,ZERO,ZNINE,X
N DIVISION,FACPNT,ONCDST,ONCSAPI,OSPIEN,RC,RESULT,STAT1
S BLANK=" "
S (IEN,ZERO)=0
S NINE=9,ZNINE="09"
;
;VACCR/STATE EXTRACT
;Loop through DATE CASE COMPLETED (165.5,90) "AAD" cross-reference
I DATEUSED=1 S START=START-1 F S START=$O(^ONCO(165.5,"AAD",START)) Q:(START<1)!(START>END) F S IEN=$O(^ONCO(165.5,"AAD",START,IEN)) Q:IEN<1 D
.Q:$G(^ONCO(165.5,IEN,0))=""
.D LOOP
;
;VACCR/STATE EXTRACT
;Loop through DATE CASE LAST CHANGED (165.5,198) "AAE" cross-reference
I DATEUSED=2 S START=START-1 F S START=$O(^ONCO(165.5,"AAE",START)) Q:(START<1)!(START>END) F S IEN=$O(^ONCO(165.5,"AAE",START,IEN)) Q:IEN<1 D
.Q:$G(^ONCO(165.5,IEN,0))=""
.D LOOP
;
Q
;
LOOP ;Apply extract selection rules
N LINE,RULES,VALID,JUMP
S RULES=0
F S RULES=$O(^ONCO(160.16,EXTRACT,"RULES",RULES)) Q:RULES<1 D
.S LINE=^ONCO(160.16,EXTRACT,"RULES",RULES,0)
.X LINE
Q:'VALID
S DIVISION=$P($G(^ONCO(165.5,IEN,"DIV")),U,1)
Q:DIVISION=""
S OSPIEN=$O(^ONCO(160.1,"C",DIVISION,0))
Q:OSPIEN=""
S FACPNT=$P($G(^ONCO(160.1,OSPIEN,1)),U,4)
Q:FACPNT=""
S STAT1=$P($G(^ONCO(160.19,FACPNT,0)),U,1)
S:$P(^ONCO(165.5,IEN,24),U,25)="" $P(^ONCO(165.5,IEN,24),U,25)=DT
D OUTPUT(IEN,EXTRACT,JUMP,.OUT)
D END^ONCSNACR(.ONCDST)
D TRAILER^ONCSAPIR(.ONCDST)
Q
;
OUTPUT(IEN,EXTRACT,JUMP,OUT) ;Output
S ONCDST=$NA(^TMP("ONCRPC",IEN))
S RC=$$RBQPREP^ONCSED01(.ONCSAPI,.ONCDST)
S ACD160=$P(^ONCO(165.5,IEN,0),U,2)
N POS S POS=0
F S POS=$O(^ONCO(160.16,EXTRACT,"FIELD","B",POS)) Q:POS<1 D Q:OUT
.N NODE S NODE=0
.F S NODE=$O(^ONCO(160.16,EXTRACT,"FIELD","B",POS,NODE)) Q:NODE<1 D Q:OUT
..N STRING,DEFAULT,FILL,LEN
..Q:$G(^ONCO(160.16,EXTRACT,"FIELD",NODE,0))=""
..;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)
..S LEN=$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,0),U,2)
..S STRING=$TR(^ONCO(160.16,EXTRACT,"FIELD",NODE,1),"~","^")
..S DEFAULT=$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,2),U,1)
..S FILL=$P(^ONCO(160.16,EXTRACT,"FIELD",NODE,3),U,1)
..D DATA(IEN,ACD160,STRING,DEFAULT,FILL,LEN,JUMP,NODE,POS)
Q
;
DATA(IEN,ACD160,STRING,DEFAULT,FILL,LEN,JUMP,NODE,POS) ;Compute extract value
N ACDANS,EXIT S EXIT=0
I JUMP'="0" D
.I POS<$P(JUMP,U) Q
.I POS>$P(JUMP,U,2) Q
.N I
.S EXIT=1
.F I=1:1:LEN W BLANK
Q:EXIT
X STRING
;
;If value = "", extract DEFAULT value
I ACDANS="" D Q
.N I,X S X=""
.I DEFAULT=8 D Q
..F I=1:1:LEN D WRITE^ONCSNACR(.ONCDST,DEFAULT)
.I @DEFAULT="09" D WRITE^ONCSNACR(.ONCDST,@DEFAULT) Q
.F I=1:1:LEN D WRITE^ONCSNACR(.ONCDST,@DEFAULT)
;
;If value too long, truncate to LENGTH (160.161,1)
;If value too short, pad with FILL (160.161,6)
I $L(ACDANS)=LEN D WRITE^ONCSNACR(.ONCDST,ACDANS) Q
I $L(ACDANS)>LEN D WRITE^ONCSNACR(.ONCDST,$E(ACDANS,1,LEN)) Q
E D Q
.N JUST,STUFF,I,REM,CAL
.S JUST=$P(FILL,","),STUFF=$P(FILL,",",2)
.S REM=LEN-$L(ACDANS)
.I JUST="R" D WRITE^ONCSNACR(.ONCDST,ACDANS)
.F I=1:1:REM D WRITE^ONCSNACR(.ONCDST,@STUFF)
.I JUST="L" D WRITE^ONCSNACR(.ONCDST,ACDANS)
Q
;
CLEANUP ;Cleanup
K DATEUSED,END,START
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCRPC 3604 printed Apr 09, 2024@21:25:37 Page 2
ONCRPC ;Hines OIFO/GWB - Extract VACCR data via ONC VACCR RPC ;09/22/11
+1 ;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
+2 ;;
EN1(RESULT,DATEUSED,START,END) ;Entry point
+1 KILL ^TMP("ONCRPC")
+2 NEW VERSION
+3 SET VERSION=$ORDER(^ONCO(160.16,"B","VACCR EXTRACT"))
+4 SET EXTRACT=$ORDER(^ONCO(160.16,"B",VERSION,0))
+5 SET OUT=0
+6 SET U="^"
+7 DO SETUP
+8 SET RESULT=$NAME(^TMP("ONCRPC"))
+9 QUIT
+10 ;
SETUP ;Loop through appropriate cross-reference
+1 NEW BLANK,DCLC,FDNUM,IEN,NC,NINE,TPG,ZERO,ZNINE,X
+2 NEW DIVISION,FACPNT,ONCDST,ONCSAPI,OSPIEN,RC,RESULT,STAT1
+3 SET BLANK=" "
+4 SET (IEN,ZERO)=0
+5 SET NINE=9
SET ZNINE="09"
+6 ;
+7 ;VACCR/STATE EXTRACT
+8 ;Loop through DATE CASE COMPLETED (165.5,90) "AAD" cross-reference
+9 IF DATEUSED=1
SET START=START-1
FOR
SET START=$ORDER(^ONCO(165.5,"AAD",START))
if (START<1)!(START>END)
QUIT
FOR
SET IEN=$ORDER(^ONCO(165.5,"AAD",START,IEN))
if IEN<1
QUIT
Begin DoDot:1
+10 if $GET(^ONCO(165.5,IEN,0))=""
QUIT
+11 DO LOOP
End DoDot:1
+12 ;
+13 ;VACCR/STATE EXTRACT
+14 ;Loop through DATE CASE LAST CHANGED (165.5,198) "AAE" cross-reference
+15 IF DATEUSED=2
SET START=START-1
FOR
SET START=$ORDER(^ONCO(165.5,"AAE",START))
if (START<1)!(START>END)
QUIT
FOR
SET IEN=$ORDER(^ONCO(165.5,"AAE",START,IEN))
if IEN<1
QUIT
Begin DoDot:1
+16 if $GET(^ONCO(165.5,IEN,0))=""
QUIT
+17 DO LOOP
End DoDot:1
+18 ;
+19 QUIT
+20 ;
LOOP ;Apply extract selection rules
+1 NEW LINE,RULES,VALID,JUMP
+2 SET RULES=0
+3 FOR
SET RULES=$ORDER(^ONCO(160.16,EXTRACT,"RULES",RULES))
if RULES<1
QUIT
Begin DoDot:1
+4 SET LINE=^ONCO(160.16,EXTRACT,"RULES",RULES,0)
+5 XECUTE LINE
End DoDot:1
+6 if 'VALID
QUIT
+7 SET DIVISION=$PIECE($GET(^ONCO(165.5,IEN,"DIV")),U,1)
+8 if DIVISION=""
QUIT
+9 SET OSPIEN=$ORDER(^ONCO(160.1,"C",DIVISION,0))
+10 if OSPIEN=""
QUIT
+11 SET FACPNT=$PIECE($GET(^ONCO(160.1,OSPIEN,1)),U,4)
+12 if FACPNT=""
QUIT
+13 SET STAT1=$PIECE($GET(^ONCO(160.19,FACPNT,0)),U,1)
+14 if $PIECE(^ONCO(165.5,IEN,24),U,25)=""
SET $PIECE(^ONCO(165.5,IEN,24),U,25)=DT
+15 DO OUTPUT(IEN,EXTRACT,JUMP,.OUT)
+16 DO END^ONCSNACR(.ONCDST)
+17 DO TRAILER^ONCSAPIR(.ONCDST)
+18 QUIT
+19 ;
OUTPUT(IEN,EXTRACT,JUMP,OUT) ;Output
+1 SET ONCDST=$NAME(^TMP("ONCRPC",IEN))
+2 SET RC=$$RBQPREP^ONCSED01(.ONCSAPI,.ONCDST)
+3 SET ACD160=$PIECE(^ONCO(165.5,IEN,0),U,2)
+4 NEW POS
SET POS=0
+5 FOR
SET POS=$ORDER(^ONCO(160.16,EXTRACT,"FIELD","B",POS))
if POS<1
QUIT
Begin DoDot:1
+6 NEW NODE
SET NODE=0
+7 FOR
SET NODE=$ORDER(^ONCO(160.16,EXTRACT,"FIELD","B",POS,NODE))
if NODE<1
QUIT
Begin DoDot:2
+8 NEW STRING,DEFAULT,FILL,LEN
+9 if $GET(^ONCO(160.16,EXTRACT,"FIELD",NODE,0))=""
QUIT
+10 ;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)
+11 SET LEN=$PIECE(^ONCO(160.16,EXTRACT,"FIELD",NODE,0),U,2)
+12 SET STRING=$TRANSLATE(^ONCO(160.16,EXTRACT,"FIELD",NODE,1),"~","^")
+13 SET DEFAULT=$PIECE(^ONCO(160.16,EXTRACT,"FIELD",NODE,2),U,1)
+14 SET FILL=$PIECE(^ONCO(160.16,EXTRACT,"FIELD",NODE,3),U,1)
+15 DO DATA(IEN,ACD160,STRING,DEFAULT,FILL,LEN,JUMP,NODE,POS)
End DoDot:2
if OUT
QUIT
End DoDot:1
if OUT
QUIT
+16 QUIT
+17 ;
DATA(IEN,ACD160,STRING,DEFAULT,FILL,LEN,JUMP,NODE,POS) ;Compute extract value
+1 NEW ACDANS,EXIT
SET EXIT=0
+2 IF JUMP'="0"
Begin DoDot:1
+3 IF POS<$PIECE(JUMP,U)
QUIT
+4 IF POS>$PIECE(JUMP,U,2)
QUIT
+5 NEW I
+6 SET EXIT=1
+7 FOR I=1:1:LEN
WRITE BLANK
End DoDot:1
+8 if EXIT
QUIT
+9 XECUTE STRING
+10 ;
+11 ;If value = "", extract DEFAULT value
+12 IF ACDANS=""
Begin DoDot:1
+13 NEW I,X
SET X=""
+14 IF DEFAULT=8
Begin DoDot:2
+15 FOR I=1:1:LEN
DO WRITE^ONCSNACR(.ONCDST,DEFAULT)
End DoDot:2
QUIT
+16 IF @DEFAULT="09"
DO WRITE^ONCSNACR(.ONCDST,@DEFAULT)
QUIT
+17 FOR I=1:1:LEN
DO WRITE^ONCSNACR(.ONCDST,@DEFAULT)
End DoDot:1
QUIT
+18 ;
+19 ;If value too long, truncate to LENGTH (160.161,1)
+20 ;If value too short, pad with FILL (160.161,6)
+21 IF $LENGTH(ACDANS)=LEN
DO WRITE^ONCSNACR(.ONCDST,ACDANS)
QUIT
+22 IF $LENGTH(ACDANS)>LEN
DO WRITE^ONCSNACR(.ONCDST,$EXTRACT(ACDANS,1,LEN))
QUIT
+23 IF '$TEST
Begin DoDot:1
+24 NEW JUST,STUFF,I,REM,CAL
+25 SET JUST=$PIECE(FILL,",")
SET STUFF=$PIECE(FILL,",",2)
+26 SET REM=LEN-$LENGTH(ACDANS)
+27 IF JUST="R"
DO WRITE^ONCSNACR(.ONCDST,ACDANS)
+28 FOR I=1:1:REM
DO WRITE^ONCSNACR(.ONCDST,@STUFF)
+29 IF JUST="L"
DO WRITE^ONCSNACR(.ONCDST,ACDANS)
End DoDot:1
QUIT
+30 QUIT
+31 ;
CLEANUP ;Cleanup
+1 KILL DATEUSED,END,START
