IBDF18E1 ;ALB/CJM - ENCOUNTER FORM - PCE DEVICE INTERFACE utilities ;04-OCT-94
;;3.0;AUTOMATED INFO COLLECTION SYS;**1,3,38,36**;APR 24, 1997
;
GETPI(PI,QLFR,TYPE) ; -- returns information about the package interface
; needed to map data to PCE DEVICE INTERFACE
;
; -- input - PI := pointer to the package interface file
; MUST be passed by reference
; QLFR := pointer to the data qualifier
; TYPE := pointer to file 359.1, applies to hand print fields
;
; -- output PI :="" if the mapping can not be determined
; PI(PI,"NODE")
; PI(PI,"VAL")
; PI(PI,"TXT")
; PI(PI,"HDR")
; PI(PI,"QLFR")
; PI(PI,"QTY")
; - if QLFR is passed, also returns PI(PI,QLFR,"IND")
; - if PI(PI,QLFR,"IND")=1,meaning there is independent mapping
; info for this qualifier - then also returns PI(PI,QLFR,"NODE")=
; <the node>,PI(PI,QLFR,"VAL")=<piece for the value>,
; PI(PI,QLFR,"TXT")=<the piece for txt>,PI(PI,QLFR,"HDR")=
; <piece for the hdr>,
; PI(PI,QLFR,"QLFR")=<piece for the qualifier code>
; - if TYPE is passed , also returns PI(PI,"TYPE",TYPE,"UNIT")=
; <unit code> and PI(PI,"TYPE",TYPE,"VTYPE")=
; <vitals type code>
;
;NOTE - it is assumed that entries in the PI() may be left hanging around,and if so they are valid
;
N NODE,QNODE,PIECE,IEN
I '$G(PI) S PI="" G GETPIQ
;
; -- type of package interface must be for input
I $P($G(^IBE(357.6,PI,0)),"^",6)'=1 S PI="" G GETPIQ
;
I '$D(PI(PI)) D Q:'PI ""
.S NODE=$G(^IBE(357.6,PI,12))
.S PI(PI,"NODE")=$P(NODE,"^")
.S PI(PI,"VAL")=$P(NODE,"^",2)
.S PI(PI,"TXT")=$P(NODE,"^",3)
.S PI(PI,"HDR")=$P(NODE,"^",4)
.S PI(PI,"QLFR")=$P(NODE,"^",5)
.S PI(PI,"QTY")=$P(NODE,"^",6)
;
; - if there is a 'PCE DIM PIECE, VARIABLE VALUE' node, execute code to
; - determine value for PCE DIM PIECE, VALUE (since it is variable, it
; - must be asked outside of the above dotted do
S X="",Y=VALUE X $G(^IBE(357.6,PI,21)) I X S PI(PI,"VAL")=X
;
;special rules apply for the VITALS node
I PI(PI,"NODE")="VITALS" D Q:'PI ""
.S PI(PI,"VAL")=2 ;the value for the VITALS node goes to piece 2
.;
.I 'TYPE D LOGERR^IBDF18E2(35791001,.FORMID,TYPE,$G(VALUE),PI) S PI(PI,"TYPE",+$G(TYPE),"VTYPE")="",PI(PI,"TYPE",+$G(TYPE),"UNIT")="" Q
.;
.;may have already gotten
.I $D(PI(PI,"TYPE",TYPE)) Q
.;
.S IEN=$O(^IBE(357.6,PI,13,"B",TYPE_";IBE(359.1,",""))
.I 'IEN D LOGERR^IBDF18E2(3576001,.FORMID,TYPE,$G(VALUE),PI) S PI(PI,"TYPE",TYPE,"VTYPE")="",PI(PI,"TYPE",TYPE,"UNIT")="" Q
.S NODE=$G(^IBE(359.1,TYPE,0))
.S PI(PI,"TYPE",TYPE,"UNIT")=$P(NODE,"^",13)
.S PI(PI,"TYPE",TYPE,"VTYPE")=$P(NODE,"^",12)
.S PI(PI,"TYPE",TYPE,"DATATYPE")=$P($G(^IBE(359.1,TYPE,10)),"^",1)
;
;if not VITALS, and there is a QLFR, get independent mapping info if not gotten previously
I PI(PI,"NODE")'="VITALS",QLFR I '$D(PI(PI,QLFR,"IND")) D Q:'PI ""
.S PI(PI,QLFR,"CODE")=$P($G(^IBD(357.98,QLFR,0)),"^",2)
.S IEN=$O(^IBE(357.6,PI,13,"B",QLFR_";IBD(357.98,",""))
.I 'IEN D LOGERR^IBDF18E2(3576002,.FORMID,$G(TYPE),$G(VALUE),PI,$G(QLFR)) S PI(PI,QLFR,"IND")=0 Q
.S NODE=$G(^IBE(357.6,PI,13,IEN,0))
.S PI(PI,QLFR,"IND")=$P(NODE,"^",3)
.Q:'PI(PI,QLFR,"IND")
.S QNODE=$P(NODE,"^",4) S:QNODE="" QNODE=PI(PI,"NODE") S PI(PI,QLFR,"NODE")=QNODE
.S PIECE=$P(NODE,"^",8) S:('PIECE)&(PI(PI,"NODE")=PI(PI,QLFR,"NODE")) PIECE=PI(PI,"QLFR") S PI(PI,QLFR,"QLFR")=PIECE
.;
.;if the node isn't different for the qualifier then the value,text,and header can not be mapped independently
.I PI(PI,"NODE")=PI(PI,QLFR,"NODE") D
..S PI(PI,QLFR,"VAL")=PI(PI,"VAL"),PI(PI,QLFR,"TXT")=PI(PI,"TXT"),PI(PI,QLFR,"HDR")=PI(PI,"HDR")
.E S PI(PI,QLFR,"VAL")=$P(NODE,"^",5),PI(PI,QLFR,"TXT")=$P(NODE,"^",6),PI(PI,QLFR,"HDR")=$P(NODE,"^",7)
.;must at least know the piece to place the returned value
.I (PI(PI,QLFR,"NODE")="")!('PI(PI,QLFR,"VAL")) S PI=""
;
;must at least know the node and the piece to place the returned value
I 'QLFR I (PI(PI,"NODE")="")!('PI(PI,"VAL")) S PI=""
GETPIQ Q PI
;
SETTEMP ; -- sets values for the field into TEMP()
; values are merged for fields that consist of a collection
;
; -- Output QCODE := <qualifier code>
; PHDR := <header piece>
; PVAL := <value piece>
; PTXT := <text piece>
; PQLFR := <qualifier piece>
; SUB := <PCE GDI node>
; NODE := <the value of the node>
; PLEX := <clinical lexicon piece, for use with diag.>
;
N QCODE,PHDR,PVAL,PTXT,PQLFR,SUB,NODE,PLEX,PQTY,SAVEPI
S SAVEPI=PI
Q:'PI
S PI=$$GETPI(.PI,QLFR,TYPE) I 'PI D LOGERR^IBDF18E2(3576003,.FORMID,$G(TYPE),$G(VALUE),SAVEPI,$G(QLFR)) Q
;
S QCODE=$S(QLFR:PI(PI,QLFR,"CODE"),1:"")
;
;determine if QCODE should be passed as VALUE
I $P($G(^IBE(357.6,PI,20)),"^") N VALUE S VALUE=QCODE
;
S PQTY=PI(PI,"QTY")
;mapping info could come from several different sources depending on whether or not a data qualifier is involved or the node=VITALS or ENCOUNTER
I QLFR,PI(PI,"NODE")'="VITALS",PI(PI,"NODE")'="ENCOUNTER" I PI(PI,QLFR,"IND") D
.S PHDR=PI(PI,QLFR,"HDR"),PVAL=PI(PI,QLFR,"VAL"),PTXT=PI(PI,QLFR,"TXT"),PQLFR=PI(PI,QLFR,"QLFR"),SUB=PI(PI,QLFR,"NODE")
E D
.S PHDR=PI(PI,"HDR"),PVAL=PI(PI,"VAL"),PTXT=PI(PI,"TXT"),PQLFR=PI(PI,"QLFR"),SUB=PI(PI,"NODE")
;
;the ENCOUNTER node is treated differently, because there is always just one of them
S:SUB'="ENCOUNTER" NODE=$G(TEMP(SUB,$P(FID,"("),+ITEM))
S:SUB="ENCOUNTER" NODE=$G(PXCA("ENCOUNTER"))
;
; -- define clin lex pointer if from data enty ($d(ibdf(item)))
; if from scanning clin lex pointer defined in ibdf18e
S PLEX=0 I SUB="DIAGNOSIS/PROBLEM" D
.S PLEX=3
.I $G(ITEM)'="" I $D(IBDF(ITEM)) S LEX=$P(IBDF(ITEM),"^",5)
;
;the VITALS node is also treated differently
I SUB="VITALS" D
.I $G(PI(PI,"TYPE",TYPE,"DATATYPE"))="f" S VALUE=+VALUE ; set floating point values to M values
.S $P(NODE,"^")=PI(PI,"TYPE",TYPE,"VTYPE"),$P(NODE,"^",3)=PI(PI,"TYPE",TYPE,"UNIT"),$P(NODE,"^",2)=VALUE,$P(NODE,"^",4)=+$G(PXCA("ENCOUNTER"))
;these are nodes other than VITALS and ENCOUNTER
E D
.;merge the data into the node
.;
.; -- for second provider entry put in provider node, always put
.; primary in encounter node
.I SUB="ENCOUNTER",PVAL=4,$P(NODE,"^",4) D Q
..I QCODE="P",$P(NODE,"^",15)'="P" S PXCA("PROVIDER",$P(NODE,"^",4))=$P(NODE,"^",15),$P(NODE,"^",4)=VALUE,$P(NODE,"^",15)=QCODE Q
..S PXCA("PROVIDER",VALUE)=QCODE Q
.;
.S NARR=+$G(NARR) ; define Narr for manual data entry
.;
.; -- change to add modifiers to visit code selected
.;
.I $P(NODE,"^",PVAL)="" D
.. S:$S(NARR=0:1,1:$P(FID,"(",2)'="N") $P(NODE,"^",PVAL)=VALUE
.. ;D MODTEMP
.I PTXT S:$P(FID,"(",2)="N"&NARR TEXT=VALUE I $S(NARR=0:$L($P(NODE,"^",PTXT))<$L(TEXT),$P(FID,"(",2)="N":TEXT'="",1:0) S $P(NODE,"^",PTXT)=TEXT
.I PHDR I $L($P(NODE,"^",PHDR))<$L(HEADER) S $P(NODE,"^",PHDR)=HEADER
.I PQTY S $P(NODE,"^",PQTY)=$G(QUANTITY)
.;
.; -- insert clin lex pointer into temp arry and re-initialize
.I $G(PLEX),$G(LEX) S $P(NODE,"^",PLEX)=LEX
.S LEX=0
.;
.I QCODE'="" S $P(NODE,"^",PQLFR)=$S($P(NODE,"^",PQLFR)'="":$P(NODE,"^",PQLFR)_","_QCODE,1:QCODE)
;
;- Prevent 'No classification' node from being set in TEMP array
;- (not dynamic)
S:SUB'="ENCOUNTER"&(SUB'="IBD NOCLASSIFICATION") TEMP(SUB,$P(FID,"("),+ITEM)=NODE
D:SUB="PROCEDURE" MODTEMP
;
;- Set Encounter and 'No classification' nodes into PXCA array
S:SUB="ENCOUNTER"!(SUB="IBD NOCLASSIFICATION") PXCA(SUB)=NODE
D:SUB="ENCOUNTER" MODTEMP
Q
MODTEMP ;-- Set up TEMP(SUB,$P(FID,"("),+ITEM, "MODIFIER array
; the CPT Modifier information is stored in the selection file(357.3)
;
;
N MCOUNT,MOD
I $D(^IBE(357.3,+$G(SLCTN),3)) D
. S MCOUNT=0
. F MOD=0:0 S MOD=$O(^IBE(357.3,SLCTN,3,MOD)) Q:'MOD D
.. S MCOUNT=MCOUNT+1
..S TEMP(SUB,$P(FID,"("),+ITEM,"MODIFIER",MCOUNT)=$P($G(^IBE(357.3,SLCTN,3,MOD,0)),"^")
.S:MCOUNT>0 TEMP(SUB,$P(FID,"("),+ITEM,"MODIFIER",0)=MCOUNT
I $D(IBDF(+ITEM,"MODIFIER")) D
. S MCOUNT=+$G(TEMP(SUB,$P(FID,"("),+ITEM,"MODIFIER",0))
. S MOD=0 F S MOD=$O(IBDF(+ITEM,"MODIFIER",MOD)) Q:'MOD D
.. S MCOUNT=MCOUNT+1
.. S TEMP(SUB,$P(FID,"("),+ITEM,"MODIFIER",MCOUNT)=IBDF(+ITEM,"MODIFIER",MOD)
. S TEMP(SUB,$P(FID,"("),+ITEM,"MODIFIER",0)=MCOUNT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF18E1 8539 printed Apr 09, 2024@21:17:05 Page 2
IBDF18E1 ;ALB/CJM - ENCOUNTER FORM - PCE DEVICE INTERFACE utilities ;04-OCT-94
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**1,3,38,36**;APR 24, 1997
+2 ;
GETPI(PI,QLFR,TYPE) ; -- returns information about the package interface
+1 ; needed to map data to PCE DEVICE INTERFACE
+2 ;
+3 ; -- input - PI := pointer to the package interface file
+4 ; MUST be passed by reference
+5 ; QLFR := pointer to the data qualifier
+6 ; TYPE := pointer to file 359.1, applies to hand print fields
+7 ;
+8 ; -- output PI :="" if the mapping can not be determined
+9 ; PI(PI,"NODE")
+10 ; PI(PI,"VAL")
+11 ; PI(PI,"TXT")
+12 ; PI(PI,"HDR")
+13 ; PI(PI,"QLFR")
+14 ; PI(PI,"QTY")
+15 ; - if QLFR is passed, also returns PI(PI,QLFR,"IND")
+16 ; - if PI(PI,QLFR,"IND")=1,meaning there is independent mapping
+17 ; info for this qualifier - then also returns PI(PI,QLFR,"NODE")=
+18 ; <the node>,PI(PI,QLFR,"VAL")=<piece for the value>,
+19 ; PI(PI,QLFR,"TXT")=<the piece for txt>,PI(PI,QLFR,"HDR")=
+20 ; <piece for the hdr>,
+21 ; PI(PI,QLFR,"QLFR")=<piece for the qualifier code>
+22 ; - if TYPE is passed , also returns PI(PI,"TYPE",TYPE,"UNIT")=
+23 ; <unit code> and PI(PI,"TYPE",TYPE,"VTYPE")=
+24 ; <vitals type code>
+25 ;
+26 ;NOTE - it is assumed that entries in the PI() may be left hanging around,and if so they are valid
+27 ;
+28 NEW NODE,QNODE,PIECE,IEN
+29 IF '$GET(PI)
SET PI=""
GOTO GETPIQ
+30 ;
+31 ; -- type of package interface must be for input
+32 IF $PIECE($GET(^IBE(357.6,PI,0)),"^",6)'=1
SET PI=""
GOTO GETPIQ
+33 ;
+34 IF '$DATA(PI(PI))
Begin DoDot:1
+35 SET NODE=$GET(^IBE(357.6,PI,12))
+36 SET PI(PI,"NODE")=$PIECE(NODE,"^")
+37 SET PI(PI,"VAL")=$PIECE(NODE,"^",2)
+38 SET PI(PI,"TXT")=$PIECE(NODE,"^",3)
+39 SET PI(PI,"HDR")=$PIECE(NODE,"^",4)
+40 SET PI(PI,"QLFR")=$PIECE(NODE,"^",5)
+41 SET PI(PI,"QTY")=$PIECE(NODE,"^",6)
End DoDot:1
if 'PI
QUIT ""
+42 ;
+43 ; - if there is a 'PCE DIM PIECE, VARIABLE VALUE' node, execute code to
+44 ; - determine value for PCE DIM PIECE, VALUE (since it is variable, it
+45 ; - must be asked outside of the above dotted do
+46 SET X=""
SET Y=VALUE
XECUTE $GET(^IBE(357.6,PI,21))
IF X
SET PI(PI,"VAL")=X
+47 ;
+48 ;special rules apply for the VITALS node
+49 IF PI(PI,"NODE")="VITALS"
Begin DoDot:1
+50 ;the value for the VITALS node goes to piece 2
SET PI(PI,"VAL")=2
+51 ;
+52 IF 'TYPE
DO LOGERR^IBDF18E2(35791001,.FORMID,TYPE,$GET(VALUE),PI)
SET PI(PI,"TYPE",+$GET(TYPE),"VTYPE")=""
SET PI(PI,"TYPE",+$GET(TYPE),"UNIT")=""
QUIT
+53 ;
+54 ;may have already gotten
+55 IF $DATA(PI(PI,"TYPE",TYPE))
QUIT
+56 ;
+57 SET IEN=$ORDER(^IBE(357.6,PI,13,"B",TYPE_";IBE(359.1,",""))
+58 IF 'IEN
DO LOGERR^IBDF18E2(3576001,.FORMID,TYPE,$GET(VALUE),PI)
SET PI(PI,"TYPE",TYPE,"VTYPE")=""
SET PI(PI,"TYPE",TYPE,"UNIT")=""
QUIT
+59 SET NODE=$GET(^IBE(359.1,TYPE,0))
+60 SET PI(PI,"TYPE",TYPE,"UNIT")=$PIECE(NODE,"^",13)
+61 SET PI(PI,"TYPE",TYPE,"VTYPE")=$PIECE(NODE,"^",12)
+62 SET PI(PI,"TYPE",TYPE,"DATATYPE")=$PIECE($GET(^IBE(359.1,TYPE,10)),"^",1)
End DoDot:1
if 'PI
QUIT ""
+63 ;
+64 ;if not VITALS, and there is a QLFR, get independent mapping info if not gotten previously
+65 IF PI(PI,"NODE")'="VITALS"
IF QLFR
IF '$DATA(PI(PI,QLFR,"IND"))
Begin DoDot:1
+66 SET PI(PI,QLFR,"CODE")=$PIECE($GET(^IBD(357.98,QLFR,0)),"^",2)
+67 SET IEN=$ORDER(^IBE(357.6,PI,13,"B",QLFR_";IBD(357.98,",""))
+68 IF 'IEN
DO LOGERR^IBDF18E2(3576002,.FORMID,$GET(TYPE),$GET(VALUE),PI,$GET(QLFR))
SET PI(PI,QLFR,"IND")=0
QUIT
+69 SET NODE=$GET(^IBE(357.6,PI,13,IEN,0))
+70 SET PI(PI,QLFR,"IND")=$PIECE(NODE,"^",3)
+71 if 'PI(PI,QLFR,"IND")
QUIT
+72 SET QNODE=$PIECE(NODE,"^",4)
if QNODE=""
SET QNODE=PI(PI,"NODE")
SET PI(PI,QLFR,"NODE")=QNODE
+73 SET PIECE=$PIECE(NODE,"^",8)
if ('PIECE)&(PI(PI,"NODE")=PI(PI,QLFR,"NODE"))
SET PIECE=PI(PI,"QLFR")
SET PI(PI,QLFR,"QLFR")=PIECE
+74 ;
+75 ;if the node isn't different for the qualifier then the value,text,and header can not be mapped independently
+76 IF PI(PI,"NODE")=PI(PI,QLFR,"NODE")
Begin DoDot:2
+77 SET PI(PI,QLFR,"VAL")=PI(PI,"VAL")
SET PI(PI,QLFR,"TXT")=PI(PI,"TXT")
SET PI(PI,QLFR,"HDR")=PI(PI,"HDR")
End DoDot:2
+78 IF '$TEST
SET PI(PI,QLFR,"VAL")=$PIECE(NODE,"^",5)
SET PI(PI,QLFR,"TXT")=$PIECE(NODE,"^",6)
SET PI(PI,QLFR,"HDR")=$PIECE(NODE,"^",7)
+79 ;must at least know the piece to place the returned value
+80 IF (PI(PI,QLFR,"NODE")="")!('PI(PI,QLFR,"VAL"))
SET PI=""
End DoDot:1
if 'PI
QUIT ""
+81 ;
+82 ;must at least know the node and the piece to place the returned value
+83 IF 'QLFR
IF (PI(PI,"NODE")="")!('PI(PI,"VAL"))
SET PI=""
GETPIQ QUIT PI
+1 ;
SETTEMP ; -- sets values for the field into TEMP()
+1 ; values are merged for fields that consist of a collection
+2 ;
+3 ; -- Output QCODE := <qualifier code>
+4 ; PHDR := <header piece>
+5 ; PVAL := <value piece>
+6 ; PTXT := <text piece>
+7 ; PQLFR := <qualifier piece>
+8 ; SUB := <PCE GDI node>
+9 ; NODE := <the value of the node>
+10 ; PLEX := <clinical lexicon piece, for use with diag.>
+11 ;
+12 NEW QCODE,PHDR,PVAL,PTXT,PQLFR,SUB,NODE,PLEX,PQTY,SAVEPI
+13 SET SAVEPI=PI
+14 if 'PI
QUIT
+15 SET PI=$$GETPI(.PI,QLFR,TYPE)
IF 'PI
DO LOGERR^IBDF18E2(3576003,.FORMID,$GET(TYPE),$GET(VALUE),SAVEPI,$GET(QLFR))
QUIT
+16 ;
+17 SET QCODE=$SELECT(QLFR:PI(PI,QLFR,"CODE"),1:"")
+18 ;
+19 ;determine if QCODE should be passed as VALUE
+20 IF $PIECE($GET(^IBE(357.6,PI,20)),"^")
NEW VALUE
SET VALUE=QCODE
+21 ;
+22 SET PQTY=PI(PI,"QTY")
+23 ;mapping info could come from several different sources depending on whether or not a data qualifier is involved or the node=VITALS or ENCOUNTER
+24 IF QLFR
IF PI(PI,"NODE")'="VITALS"
IF PI(PI,"NODE")'="ENCOUNTER"
IF PI(PI,QLFR,"IND")
Begin DoDot:1
+25 SET PHDR=PI(PI,QLFR,"HDR")
SET PVAL=PI(PI,QLFR,"VAL")
SET PTXT=PI(PI,QLFR,"TXT")
SET PQLFR=PI(PI,QLFR,"QLFR")
SET SUB=PI(PI,QLFR,"NODE")
End DoDot:1
+26 IF '$TEST
Begin DoDot:1
+27 SET PHDR=PI(PI,"HDR")
SET PVAL=PI(PI,"VAL")
SET PTXT=PI(PI,"TXT")
SET PQLFR=PI(PI,"QLFR")
SET SUB=PI(PI,"NODE")
End DoDot:1
+28 ;
+29 ;the ENCOUNTER node is treated differently, because there is always just one of them
+30 if SUB'="ENCOUNTER"
SET NODE=$GET(TEMP(SUB,$PIECE(FID,"("),+ITEM))
+31 if SUB="ENCOUNTER"
SET NODE=$GET(PXCA("ENCOUNTER"))
+32 ;
+33 ; -- define clin lex pointer if from data enty ($d(ibdf(item)))
+34 ; if from scanning clin lex pointer defined in ibdf18e
+35 SET PLEX=0
IF SUB="DIAGNOSIS/PROBLEM"
Begin DoDot:1
+36 SET PLEX=3
+37 IF $GET(ITEM)'=""
IF $DATA(IBDF(ITEM))
SET LEX=$PIECE(IBDF(ITEM),"^",5)
End DoDot:1
+38 ;
+39 ;the VITALS node is also treated differently
+40 IF SUB="VITALS"
Begin DoDot:1
+41 ; set floating point values to M values
IF $GET(PI(PI,"TYPE",TYPE,"DATATYPE"))="f"
SET VALUE=+VALUE
+42 SET $PIECE(NODE,"^")=PI(PI,"TYPE",TYPE,"VTYPE")
SET $PIECE(NODE,"^",3)=PI(PI,"TYPE",TYPE,"UNIT")
SET $PIECE(NODE,"^",2)=VALUE
SET $PIECE(NODE,"^",4)=+$GET(PXCA("ENCOUNTER"))
End DoDot:1
+43 ;these are nodes other than VITALS and ENCOUNTER
+44 IF '$TEST
Begin DoDot:1
+45 ;merge the data into the node
+46 ;
+47 ; -- for second provider entry put in provider node, always put
+48 ; primary in encounter node
+49 IF SUB="ENCOUNTER"
IF PVAL=4
IF $PIECE(NODE,"^",4)
Begin DoDot:2
+50 IF QCODE="P"
IF $PIECE(NODE,"^",15)'="P"
SET PXCA("PROVIDER",$PIECE(NODE,"^",4))=$PIECE(NODE,"^",15)
SET $PIECE(NODE,"^",4)=VALUE
SET $PIECE(NODE,"^",15)=QCODE
QUIT
+51 SET PXCA("PROVIDER",VALUE)=QCODE
QUIT
End DoDot:2
QUIT
+52 ;
+53 ; define Narr for manual data entry
SET NARR=+$GET(NARR)
+54 ;
+55 ; -- change to add modifiers to visit code selected
+56 ;
+57 IF $PIECE(NODE,"^",PVAL)=""
Begin DoDot:2
+58 if $SELECT(NARR=0
SET $PIECE(NODE,"^",PVAL)=VALUE
+59 ;D MODTEMP
End DoDot:2
+60 IF PTXT
if $PIECE(FID,"(",2)="N"&NARR
SET TEXT=VALUE
IF $SELECT(NARR=0:$LENGTH($PIECE(NODE,"^",PTXT))<$LENGTH(TEXT),$PIECE(FID,"(",2)="N":TEXT'="",1:0)
SET $PIECE(NODE,"^",PTXT)=TEXT
+61 IF PHDR
IF $LENGTH($PIECE(NODE,"^",PHDR))<$LENGTH(HEADER)
SET $PIECE(NODE,"^",PHDR)=HEADER
+62 IF PQTY
SET $PIECE(NODE,"^",PQTY)=$GET(QUANTITY)
+63 ;
+64 ; -- insert clin lex pointer into temp arry and re-initialize
+65 IF $GET(PLEX)
IF $GET(LEX)
SET $PIECE(NODE,"^",PLEX)=LEX
+66 SET LEX=0
+67 ;
+68 IF QCODE'=""
SET $PIECE(NODE,"^",PQLFR)=$SELECT($PIECE(NODE,"^",PQLFR)'="":$PIECE(NODE,"^",PQLFR)_","_QCODE,1:QCODE)
End DoDot:1
+69 ;
+70 ;- Prevent 'No classification' node from being set in TEMP array
+71 ;- (not dynamic)
+72 if SUB'="ENCOUNTER"&(SUB'="IBD NOCLASSIFICATION")
SET TEMP(SUB,$PIECE(FID,"("),+ITEM)=NODE
+73 if SUB="PROCEDURE"
DO MODTEMP
+74 ;
+75 ;- Set Encounter and 'No classification' nodes into PXCA array
+76 if SUB="ENCOUNTER"!(SUB="IBD NOCLASSIFICATION")
SET PXCA(SUB)=NODE
+77 if SUB="ENCOUNTER"
DO MODTEMP
+78 QUIT
MODTEMP ;-- Set up TEMP(SUB,$P(FID,"("),+ITEM, "MODIFIER array
+1 ; the CPT Modifier information is stored in the selection file(357.3)
+2 ;
+3 ;
+4 NEW MCOUNT,MOD
+5 IF $DATA(^IBE(357.3,+$GET(SLCTN),3))
Begin DoDot:1
+6 SET MCOUNT=0
+7 FOR MOD=0:0
SET MOD=$ORDER(^IBE(357.3,SLCTN,3,MOD))
if 'MOD
QUIT
Begin DoDot:2
+8 SET MCOUNT=MCOUNT+1
+9 SET TEMP(SUB,$PIECE(FID,"("),+ITEM,"MODIFIER",MCOUNT)=$PIECE($GET(^IBE(357.3,SLCTN,3,MOD,0)),"^")
End DoDot:2
+10 if MCOUNT>0
SET TEMP(SUB,$PIECE(FID,"("),+ITEM,"MODIFIER",0)=MCOUNT
End DoDot:1
+11 IF $DATA(IBDF(+ITEM,"MODIFIER"))
Begin DoDot:1
+12 SET MCOUNT=+$GET(TEMP(SUB,$PIECE(FID,"("),+ITEM,"MODIFIER",0))
+13 SET MOD=0
FOR
SET MOD=$ORDER(IBDF(+ITEM,"MODIFIER",MOD))
if 'MOD
QUIT
Begin DoDot:2
+14 SET MCOUNT=MCOUNT+1
+15 SET TEMP(SUB,$PIECE(FID,"("),+ITEM,"MODIFIER",MCOUNT)=IBDF(+ITEM,"MODIFIER",MOD)
End DoDot:2
+16 SET TEMP(SUB,$PIECE(FID,"("),+ITEM,"MODIFIER",0)=MCOUNT
End DoDot:1
+17 QUIT
