IBDF4 ;ALB/CJM - ENCOUNTER FORM - BUILD FORM(editing group's selections) ;11/16/92
;;3.0;AUTOMATED INFO COLLECTION SYS;**19,38,56,63,70**;APR 24, 1997;Build 46
;
;
SLCTNS ;
N IBRTN
Q:IBLIST'=$P($G(^IBE(357.4,IBGRP,0)),"^",3)
S IBRTN=IBLIST("RTN")
D RTNDSCR^IBDFU1B(.IBRTN)
D KILL^IBDFUA
D EN^VALM("IBDF EDIT GROUP'S SELECTIONS") ;call the list manager
Q
ONENTRY ;entry code for list manager
D IDXSLCTN
Q
ONEXIT ;exit code for the list manager
K @VALMAR
Q
;
IDXSLCTN ;build an array of selections in print order for the list processor
N SLCTN,ODR,NODE
K @VALMAR
I '$D(^TMP("IBDF DELETE SELECTION OPTION",$J)) S ^TMP("IBDF DELETE SELECTION OPTION",$J)=0
S ODR="",VALMCNT=0
F S ODR=$O(^IBE(357.3,"APO",IBLIST,IBGRP,ODR)) Q:ODR="" D
.S SLCTN="" F S SLCTN=$O(^IBE(357.3,"APO",IBLIST,IBGRP,ODR,SLCTN)) Q:'SLCTN D
..;check for messed up index and take appropriate action
..S NODE=$G(^IBE(357.3,SLCTN,0))
..I ($P(NODE,"^",3)'=IBLIST)!($P(NODE,"^",4)'=IBGRP) D Q
...K ^IBE(357.3,"APO",IBLIST,IBGRP,ODR,SLCTN)
...I $P(NODE,"^",3)'=IBLIST,$P(NODE,"^",4)=IBGRP D Q
....K DIK,DA S DIK="^IBE(357.3,",DA=SLCTN D ^DIK K DIK,DA
...I $P(NODE,"^",3)=IBLIST,$P($G(^IBE(357.4,+IBGRP,0)),"^",3)'=IBLIST D Q
....K DIK,DA S DIK="^IBE(357.3,",DA=SLCTN D ^DIK K DIK,DA
...K DIK,DA S DIK="^IBE(357.3,",DA=SLCTN D IX^DIK K DIK,DA
..;
..S VALMCNT=VALMCNT+1
..S @VALMAR@(VALMCNT,0)=$$DISPLAY(SLCTN,VALMCNT),@VALMAR@("IDX",VALMCNT,VALMCNT)=SLCTN
..D FLDCTRL^VALM10(VALMCNT,"ID") ;set video for ID column
I ^TMP("IBDF DELETE SELECTION OPTION",$J)=1,'$O(^IBE(357.3,"APO",IBLIST,IBGRP,"")) D ;User deleted all selections. Update history files during save.
.S ^TMP("IBDF DELETED ALL SELECTIONS",$J)=1
Q
LMGRPHDR ;header for the screen
S VALMHDR(1)="SELECTIONS CURRENTLY DEFINED FOR '"_$$GRPNAME_"' PRINT GROUP"
Q
;
GRPNAME() ;the name of the selection group
Q $P($G(^IBE(357.4,IBGRP,0)),"^",1)
;
DISPLAY(SLCTN,COUNT) ;returns a line to display to the list containing a selection - SLCTN is a ptr to the selection, COUNT is the number of the selection on the list
N SC,SCDA,VAL,RET,W,NODE,ORDER
;W - an array containing the widths of the subcolumns that contain text
S VAL=""
S RET=$$PADRIGHT^IBDFU(COUNT,4)
S NODE=$G(^IBE(357.3,SLCTN,0))
S ORDER=$P(NODE,"^",5),RET=RET_$J(ORDER,6,2)
I $P(NODE,"^",2) S RET=RET_$S($P(NODE,"^",7):" SH",1:" PH")_"| "_$P(NODE,"^",6)
I '$P(NODE,"^",2) S RET=RET_" ",SC="" F SC=1:1:8 S SCDA=$O(^IBE(357.3,SLCTN,1,"B",SC,"")) D
.I $G(IBLIST("SCTYPE",SC))=1 S W(SC)=IBLIST("SCW",SC)*(1+IBLIST("BTWN"))
.S:$G(W(SC)) VAL=$$PADRIGHT^IBDFU($S(SCDA:$P($G(^IBE(357.3,SLCTN,1,SCDA,0)),"^",2),1:""),W(SC))
.S:VAL'="" RET=RET_" | "_VAL
.S VAL=""
I $D(^IBE(357.3,SLCTN,2)) S RET=RET_" ",SC="" F SC=1:1:2 S SCDA=$P(^IBE(357.3,SLCTN,2),"^",SC) S:SC=2 SCDA=$S($D(^LEX)>1:$P($G(^LEX(757.01,+SCDA,0)),"^"),1:$P($G(^GMP(757.01,+SCDA,0)),"^")) D
.S W(SC)=25
.S VAL=$$PADRIGHT^IBDFU($S(SCDA]"":SCDA,1:""),W(SC))
.S:VAL'="" RET=RET_" | "_VAL
.S VAL=""
Q RET
ADDSLCTN ;allows the user to add a selection to the selection group
N QUIT,SUB
;
S VALMBCK="R"
D FULL^VALM1
I IBRTN("ACTION")'=3 D NOGOOD G ADDEXIT
S ^TMP("IBDF ADDSLCTN",$J)=1
K @IBRTN("DATA_LOCATION")
S QUIT=0 F D Q:QUIT W !!!,"Now for another SELECTION LIST entry!"
.I '$$DORTN^IBDFU1B(.IBRTN) S QUIT=1 D NOGOOD Q
.I '$D(@IBRTN("DATA_LOCATION")) S QUIT=1 Q
.D ADDREC(.QUIT) ;edits and adds the selection
.K @IBRTN("DATA_LOCATION")
ADDEXIT ;
D IDXSLCTN
Q
;IBDEXCOD - the external code that we are adding to the group (optional)
ADDREC(QUIT,ORDER,SLCTN,IBDEXCOD,IBDALL) ;allows the user to number the selection, edit the editable subcolumns, then adds the record - sets QUIT=1 if user quits
N SUB,COUNT,NODE,VAL,DLAYGO,QTY,DTOUT,DUOUT,DIRUT
I $P($G(^IBE(357.6,$P($G(^IBE(357.2,+IBLIST,0)),"^",11),16)),"^",8) S DIR(0)="NO",DIR("A")="Quantity",DIR("B")=1,DIR("?")="Enter the number of occurrences" D ^DIR K DIR S:$D(DTOUT)!$D(DUOUT) QUIT=1 Q:QUIT S QTY=$G(Y)
I '$G(ORDER) D Q:QUIT
.K DIR S DIR(0)="357.3,.05",DIR("B")=$$NEXT^IBDF4A(IBLIST,IBGRP) D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q
.S ORDER=+Y
S VAL=$G(@IBRTN("DATA_LOCATION"))
Q:QUIT
;we have all the data needed to add the selection - so add it
S NODE=$S($P(VAL,"^")'="":$P(VAL,"^"),1:ORDER)_"^^"_IBLIST_"^"_IBGRP_"^"_ORDER_$S($G(QTY):"^^^^"_QTY,1:"")
K DIC,DD,DO,DINUM S DIC="^IBE(357.3,",X=$P(NODE,"^",1),DIC(0)="FL",DLAYGO=357.3
D FILE^DICN K DIC,DIE,DA
S SLCTN=$S(+Y<0:"",1:+Y)
I 'SLCTN W !,"Unable to create a new selection record!" D PAUSE^VALM1 S QUIT=1 Q
S ^IBE(357.3,SLCTN,0)=NODE
;--- move codes and add modifiers
D CODES^IBDF4A(.QUIT)
Q:QUIT
D ADD^IBDF4C
;---move the subcolumn set up
F SUB=1:1:8 D Q:QUIT
.I $G(IBLIST("SCTYPE",SUB))=1 I IBLIST("SCPIECE",SUB),IBLIST("SCW",SUB) D
..S NODE=$$DATANODE^IBDFU1B(IBRTN,IBLIST("SCPIECE",SUB))
..I NODE]"" S VAL(SUB)=$P($G(@IBRTN("DATA_LOCATION")@(NODE)),"^",IBLIST("SCPIECE",SUB))
..E S VAL(SUB)=$P(VAL,"^",IBLIST("SCPIECE",SUB))
..Q:('IBLIST("SCEDITABLE",SUB))!((IBRTN("WIDTH",1))&(IBLIST("SCPIECE",SUB)=1))
..W !!,"Subcolumn Header: "_IBLIST("SCHDR",SUB) K DIR S DIR(0)="FO^0:"_(IBLIST("SCW",SUB)*(1+IBLIST("BTWN"))),DIR("A")="Edit Subcolumn "_SUB,DIR("B")=VAL(SUB)_$S($G(QTY)>1:" x "_QTY,1:"")
..I $P($G(^IBE(357.3,SLCTN,3,0)),"^",4)>0 D
...S:DIR("B")'["w/ mod" DIR("B")=DIR("B")_"w/ mod"
..D ^DIR K DIR S:$D(DTOUT)!($D(DUOUT)) QUIT=1 Q:QUIT S VAL(SUB)=Y I IBLIST("SCPIECE",SUB)=1,X="" S QUIT=1 Q
Q:QUIT
;
;add the subcolumn value multiple
S COUNT=0 F SUB=1:1:8 I $G(VAL(SUB))'="" S COUNT=COUNT+1,^IBE(357.3,SLCTN,1,COUNT,0)=SUB_"^"_VAL(SUB)
S ^IBE(357.3,SLCTN,1,0)="^357.31IA^"_COUNT_"^"_COUNT
K DA S DA=SLCTN,DIK="^IBE(357.3," D IX^DIK K DIK,DA
D NARR(.QUIT)
Q:QUIT
D TERM(.QUIT,$G(IBDEXCOD))
I $G(IBDRPCAL) S:$G(IBDAI)="DG SELECT ICD-10 DIAGNOSIS CODES" IBDX=$$CSUPD357^IBDUTICD(IBFORM,30,"",$$NOW^XLFDT(),DUZ) D ADDALREC(IBSEL)
Q
;
NARR(IBDQUIT) ; -- edit provider narrative, but only for selections where the
; interface allows editing
N DIE,DA,DR,Y
I $P($G(^IBE(357.6,+$P($G(^IBE(357.2,+IBLIST,0)),U,11),0)),U,17) D
.S DIE="^IBE(357.3,",DA=SLCTN,DR=2.01 D ^DIE K DIE,DA,DR
I $D(Y) S IBDQUIT=1
Q
;IBDCODEX - the external code that we are adding to the group (optional)
TERM(IBDQUIT,IBDCODEX) ; -- map selection to clinical lexicon, but only for selections where
; the package interface allows editing
;newed DIC to prevent bug in Lexicon
N DIE,DA,DR,GMPTUN,GMPTSUB,GMPTSHOW,XTLKGLB,XTLKHLP,XTLKKSCH,XTLKSAY,IBDLEX,DIC,IBDDT
N LEXQ,LEXVDT,Y,IBLEXNS,IBDLEXSS,IBD1STDT,IBDIMPDT
;
S IBLEXNS="GMPL",IBDLEXSS="PL1"
;if this is ICD package interface then if it is ICD-10 then used "10D" if anything else (ICD9 at the moment) - use "ICD"
I $G(IBRTN("NAME"))["ICD" S (IBLEXNS,IBDLEXSS)=$S($G(IBRTN("NAME"))["ICD-10":"10D",1:"ICD")
;
S IBDDT="" ;keep using "" for ICD-9
;for ICD-10 codes:
;if IBDCODEX is not provided then use ICD-10 implementation date if it is prior to the ICD-10 implementation date
; and default if it is on and after
;if IBDCODEX is defined we rely on the selection logic (see FILTER^IBDUTICD). To pass CONFIG^LEXSET we
; use the latest ACTIVE status date of the code
I $G(IBRTN("NAME"))["ICD-10" D
. ; get the ICD-10 activation date
. S IBDIMPDT=$$IMPDATE^IBDUTICD("10D")
. ;if code value is NOT defined/not available then
. ; set the date to ICD-10 activation if the user adds the code prior to ICD-10 system activation
. ; and to default "" if in and after ICD-10 activation and quit
. I $G(IBDCODEX)="" S IBDDT=$S(DT<IBDIMPDT:IBDIMPDT,1:"") Q
. ;if code value is available then get the date of the last ACTIVE status and use it for CONFIG^LEXSET
. S IBDDT=$$LSTACTST^IBDUTICD(IBDCODEX)
. ;if not found for some reason then follow the logic "when the code is NOT available" above
. I IBDDT=0 S IBDDT=$S(DT<IBDIMPDT:IBDIMPDT,1:"")
I $P($G(^IBE(357.6,+$P($G(^IBE(357.2,+IBLIST,0)),U,11),0)),U,18) D
.I $D(^LEX)>1 S X="LEXSET" X ^%ZOSF("TEST") I $T D CONFIG^LEXSET(IBLEXNS,IBDLEXSS,IBDDT) S IBDLEX=1
.I '$D(IBDLEX) S X="GMPTSET" X ^%ZOSF("TEST") I $T D CONFIG^GMPTSET(IBLEXNS,IBDLEXSS,IBDDT) S IBDLEX=1
.;D CONFIG^GMPTSET("ICD","ICD") (this is an alternate filter)
.Q:'$D(IBDLEX)
.S DIE="^IBE(357.3,",DA=SLCTN,DR="2.02//"_$P($G(^IBE(357.3,DA,0)),"^") D ^DIE
K DIC
I $D(Y) S IBDQUIT=1
Q
;
CODES ; -- allow selection of a second code to pass through for this entry
; -- only as if pi allows input of more than one code
;N PI S PI=+$P($G(^IBE(357.2,+IBLIST,0)),U,11)
;Q:'$P($G(^IBE(357.6,PI,16)),U,9)
;N IBI,QUIT,IBVAL S QUIT=0
;F IBI=1,2 D Q:QUIT
;.W !,"****Select a ",$S(IBI=1:"second",1:"third")," code to pass along with original."
;.I '$$DORTN^IBDFU1B(.IBRTN) S QUIT=1 Q
;.I +Y'>0 S QUIT=1 Q
;.X $G(^IBE(357.6,PI,9)) S IBVAL=X
;.S DIE="^IBE(357.3,",DA=SLCTN,DR=$S(IBI=1:"2.03",1:"2.04")_"////^S X=IBVAL" D ^DIE K DIE,DA,DR
;Q
;
NOGOOD ;
W !,"The package interface routine for selection is not properly defined" D PAUSE^VALM1
Q
;
SEQUENCE ;allows the user to resequence all of the selections on the list
;
N SUBCOL,CNT,P,SORT,GROUP,NODE,VALUE,ITEM,IEN,HDR,DTOUT,DUOUT,DIRUT,SORT1
S VALMBCK="R"
D FULL^VALM1
;
;sort by which subcolumn?
K DIR S DIR("A")="Which subcolumn do you want to sort by?",DIR("?")=" "
S SUBCOL=0 F S SUBCOL=$O(IBLIST("SCTYPE",SUBCOL)) Q:'SUBCOL I IBLIST("SCTYPE",SUBCOL)=1 S SUBCOL(SUBCOL)=""
S (CNT,SUBCOL)=0,DIR(0)="SOX^"
F CNT=1:1 S SUBCOL=$O(SUBCOL(SUBCOL)) Q:'SUBCOL D
.S P=IBLIST("SCPIECE",SUBCOL),P=$S(P=1:1,P=2:3,P=3:5,P=4:7,P=5:9,P=6:11,P=7:13,1:0),HDR=$P($G(^IBE(357.6,+IBLIST("RTN"),2)),"^",P),DIR("?",CNT)=SUBCOL_" = "_HDR
.S HDR=$S($G(IBLIST("SCHDR",SUBCOL))="":HDR,1:IBLIST("SCHDR",SUBCOL))
.S DIR(0)=DIR(0)_SUBCOL_":"_HDR_";"
D ^DIR
Q:$D(DIRUT)!(Y=-1)
K SUBCOL S SUBCOL=+Y
;
;sort alphabetically or numerically?
K DIR
S DIR("A")="How should the list be sorted?",DIR(0)="SO^1:ALPHABETICALLY;2:NUMERICALLY;",DIR("B")="ALPHABETICALLY"
D ^DIR
Q:$D(DIRUT)!(Y=-1)
S SORT=Y
; -- Resequence by group or group and placeholders
K DIR
S DIR("A")="Resequence by Group or Group and Place Holders?",DIR(0)="SO^1:GROUP/PLACE HOLDERS;2:GROUP;",DIR("B")="GROUP/PLACE HOLDERS"
D ^DIR
Q:$D(DIRUT)!(Y=-1)
S SORT1=Y
;
;sort
I SORT1=2 D EN^IBDF4A Q
N CNTR,GROUP1,IBGROUP,IBORDER
K ^TMP("IBDF",$J)
S (GROUP,GROUP1,CNTR,IBGROUP)=0
; -- Resequence only specific groups in block.
I $D(IBGRUP) F S IBGROUP=$O(IBGRUP(IBGROUP)) Q:'IBGROUP D RESEQ
I $D(IBGRUP) D ORDER Q
; -- Resequence all groups of the block.
I '$D(IBGRUP) F S IBGROUP=$O(^IBE(357.3,"APO",IBLIST,IBGROUP)) Q:'IBGROUP D RESEQ
I '$D(IBGRUP) D ORDER Q
Q
RESEQ S IBORDER=0 F S IBORDER=$O(^IBE(357.3,"APO",IBLIST,IBGROUP,IBORDER)) Q:'IBORDER S ITEM=0 F S ITEM=$O(^IBE(357.3,"APO",IBLIST,IBGROUP,IBORDER,ITEM)) Q:'ITEM D
.S NODE=$G(^IBE(357.3,ITEM,0))
.I ($P(NODE,"^",3)'=IBLIST) Q
.S GROUP1=GROUP,GROUP=+$P(NODE,"^",4)
.Q:$P($G(^IBE(357.4,GROUP,0)),"^",3)'=IBLIST
.I $P(NODE,"^",2)=1 D Q
..S CNTR=CNTR+1
..S VALUE=$S(SORT=1:" ",1:+$P(NODE,"^",1))
..S ^TMP("IBDF",$J,"RESEQUENCE LIST",GROUP,CNTR,VALUE,ITEM)=""
.S IEN=$O(^IBE(357.3,ITEM,1,"B",SUBCOL,0)) Q:'IEN
.S VALUE=$P($G(^IBE(357.3,ITEM,1,IEN,0)),"^",2)
.S VALUE=$S(SORT=1:VALUE=" "_VALUE,1:+$P(NODE,"^",1))
.I GROUP'=GROUP1 S CNTR=CNTR+1
.S ^TMP("IBDF",$J,"RESEQUENCE LIST",GROUP,CNTR,$E(VALUE,1,40),ITEM)=""
;set the order
ORDER S GROUP=0,CNTR=0
F S GROUP=$O(^TMP("IBDF",$J,"RESEQUENCE LIST",GROUP)) Q:'GROUP D
.S VALUE="",CNT=0
.F S CNTR=$O(^TMP("IBDF",$J,"RESEQUENCE LIST",GROUP,CNTR)) Q:'CNTR F S VALUE=$O(^TMP("IBDF",$J,"RESEQUENCE LIST",GROUP,CNTR,VALUE)) Q:VALUE="" D
..S ITEM=0 F S ITEM=$O(^TMP("IBDF",$J,"RESEQUENCE LIST",GROUP,CNTR,VALUE,ITEM)) Q:'ITEM D
...S CNT=CNT+1
...K DIE,DA,DR S DIE="^IBE(357.3,",DR=".05///"_CNT,DA=ITEM D ^DIE K DIE,DA,DR
;
K Y,X,DIR,^TMP("IBDF",$J,"RESEQUENCE LIST")
D IDXGRP^IBDF3
Q
ADDALREC(IBSEL) ;updates all forms with the same code
N IBDCD,IBDY,IBDNODE,IBDOLD,IBDERR,IBDN,IBDSUB,IBDSUB1,IBDN1,IBDATA,IBDNEW,IBDCODE,IBDFRN,IBDBLK,IBDFRM1,IBDFORM,IBDDPC,IBDDUP,IBDTMP1,IBDCL,IBDYS,IBDSBI,IBDSELN,IBDSNEW,DA,DIK
N IBDFSEL,IBDATA1,IBBLK,IBDANT
S IBDANT=1
K ^TMP("IBDANT",$J) S ^TMP("IBDANT",$J,IBDANT)=^IBE(357.3,SLCTN,0)
S IBDCD=$P(IBDFSLC,U) S IBDY=0 F S IBDY=$O(^XTMP("CPTIDX",IBDY)) Q:'IBDY I $P(^XTMP("CPTIDX",IBDY),U,2)=IBDCD D
.S IBDDPC=0,IBDDUP=0 F S IBDDPC=$O(IBDSEL1(IBDDPC)) Q:'IBDDPC D
..I $P(^XTMP("CPTIDX",IBDY),U,2,6)=$P(^XTMP("CPTIDX",IBDDPC),U,2,6) S IBDDUP=1,IBDTMP1=$P($G(^XTMP("CPTIDX",IBDY)),"^") S DA=$P(^XTMP("CPTIDX",IBDDPC),U,4),DIK="^IBE(357.3," D ^DIK K DIK
.I IBDDUP S:^XTMP("IBDCPT",IBDTMP1,0)'=" " ^XTMP("IBDCPT",IBDTMP1,0)=$P(^XTMP("IBDCPT",IBDTMP1,0),")")_") *******Replaced*******" D Q
..S IBDFSEL=$P(^XTMP("CPTIDX",IBDY),U,4)
..S ^XTMP("CPTIDX",IBDY)="*Replaced*"
.S IBDFORM=$P($G(^XTMP("CPTIDX",IBDY)),"^",5)
.S IBDTMP1=$P($G(^XTMP("CPTIDX",IBDY)),"^")
.S IBBLK=$P($G(^XTMP("CPTIDX",IBDY)),"^",6)
.S IBDFSEL=$P(^XTMP("CPTIDX",IBDY),U,4) S IBDNODE=$G(^IBE(357.3,IBDFSEL,0)) I IBDNODE="" D Q
..S:^XTMP("IBDCPT",IBDTMP1,0)'=" " ^XTMP("IBDCPT",IBDTMP1,0)=$P(^XTMP("IBDCPT",IBDTMP1,0),")")_") *******Replaced*******" S ^XTMP("CPTIDX",IBDY)="*Replaced*"
.K DIC,DD,DO,DINUM S DIC="^IBE(357.3,",X=$P(^IBE(357.3,IBSEL,0),"^",1),DIC(0)="FL",DLAYGO=357.3 D FILE^DICN S IBDNEW=+Y K DIC,DIE,DA
.S IBDYS=IBDFSEL_"," D GETS^DIQ(357.3,IBDYS,"**","NI","IBDOLD","IBDERR")
.S IBDN=.01,DIE="^IBE(357.3,",DA=IBDNEW F S IBDN=$O(IBDOLD(357.3,IBDYS,IBDN)) Q:'IBDN D
..S IBDATA=IBDOLD(357.3,IBDYS,IBDN,"I") I IBDATA'="" I IBDN'=.03 I IBDN'=.04 I IBDN'=2.02 I IBDN'=4.02 S DR=IBDN_"///"_IBDATA D ^DIE
.S IBDATA=$G(IBDOLD(357.3,IBDYS,.03,"I")) I IBDATA'="" S DR=".03////"_IBDATA D ^DIE
.S IBDATA=$G(IBDOLD(357.3,IBDYS,.04,"I")) I IBDATA'="" S DR=".04////"_IBDATA D ^DIE
.S IBDATA=$G(IBDOLD(357.3,IBDYS,2.02,"I")) I IBDATA'="" S DR="2.02////"_IBDATA D ^DIE
.S IBDATA=$G(IBDOLD(357.3,IBDYS,4.02,"I")) I IBDATA'="" S DR="4.02////"_IBDATA D ^DIE
.S IBDSELN=IBSEL_"," D GETS^DIQ(357.3,IBDSELN,"**","N","IBDCODE","IBDERR")
.I $D(IBDCODE(357.31)) S IBDSUB="" F S IBDSUB=$O(IBDCODE(357.31,IBDSUB)) Q:IBDSUB="" S IBDSBI=IBDCODE(357.31,IBDSUB,.01) S DIC="^IBE(357.3,"_IBDNEW_",1,",X=IBDSBI,DA(1)=IBDNEW,DA=X,DIC(0)="FL",DLAYGO=357.31 D FILE^DICN S IBDSNEW=+Y D
..S IBDN1=.01,DIE="^IBE(357.3,"_DA(1)_",1,",DA(1)=IBDNEW,DA=IBDSNEW,IBDSUB1=.01 F S IBDSUB1=$O(IBDCODE(357.31,IBDSUB,IBDSUB1)) Q:IBDSUB1="" S IBDATA1=IBDCODE(357.31,IBDSUB,IBDSUB1) I IBDATA1'="" S DR=IBDSUB1_"///^S X=IBDATA1" D ^DIE
.I $D(IBDCODE(357.33)) S IBDSUB="" F S IBDSUB=$O(IBDCODE(357.33,IBDSUB)) Q:IBDSUB="" S IBDSBI=IBDCODE(357.33,IBDSUB,.01) S DIC="^IBE(357.3,"_IBDNEW_",3,",X=IBDSBI,DA(1)=IBDNEW,DA=X,DIC(0)="FL",DLAYGO=357.33 D FILE^DICN S IBDSNEW=+Y D
..S IBDN1=.01,DIE="^IBE(357.3,"_DA(1)_",3,",DA(1)=IBDNEW,DA=IBDSNEW,IBDSUB1=.01 F S IBDSUB1=$O(IBDCODE(357.33,IBDSUB,IBDSUB1)) Q:IBDSUB1="" S IBDATA1=IBDCODE(357.31,IBDSUB,IBDSUB1) I IBDATA1'="" S DR=IBDSUB1_"///^S X=IBDATA1" D ^DIE
.S DA=IBDFSEL,DIK="^IBE(357.3," D ^DIK K DIK
.S IBDANT=IBDANT+1,^TMP("IBDANT",$J,IBDANT)=^IBE(357.3,IBDNEW,0)
.S:^XTMP("IBDCPT",IBDTMP1,0)'=" " ^XTMP("IBDCPT",IBDTMP1,0)=$P(^XTMP("IBDCPT",IBDTMP1,0),")")_") *******Replaced*******" S ^XTMP("CPTIDX",IBDY)="*Replaced*"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF4 15608 printed Jan 18, 2025@03:52:38 Page 2
IBDF4 ;ALB/CJM - ENCOUNTER FORM - BUILD FORM(editing group's selections) ;11/16/92
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**19,38,56,63,70**;APR 24, 1997;Build 46
+2 ;
+3 ;
SLCTNS ;
+1 NEW IBRTN
+2 if IBLIST'=$PIECE($GET(^IBE(357.4,IBGRP,0)),"^",3)
QUIT
+3 SET IBRTN=IBLIST("RTN")
+4 DO RTNDSCR^IBDFU1B(.IBRTN)
+5 DO KILL^IBDFUA
+6 ;call the list manager
DO EN^VALM("IBDF EDIT GROUP'S SELECTIONS")
+7 QUIT
ONENTRY ;entry code for list manager
+1 DO IDXSLCTN
+2 QUIT
ONEXIT ;exit code for the list manager
+1 KILL @VALMAR
+2 QUIT
+3 ;
IDXSLCTN ;build an array of selections in print order for the list processor
+1 NEW SLCTN,ODR,NODE
+2 KILL @VALMAR
+3 IF '$DATA(^TMP("IBDF DELETE SELECTION OPTION",$JOB))
SET ^TMP("IBDF DELETE SELECTION OPTION",$JOB)=0
+4 SET ODR=""
SET VALMCNT=0
+5 FOR
SET ODR=$ORDER(^IBE(357.3,"APO",IBLIST,IBGRP,ODR))
if ODR=""
QUIT
Begin DoDot:1
+6 SET SLCTN=""
FOR
SET SLCTN=$ORDER(^IBE(357.3,"APO",IBLIST,IBGRP,ODR,SLCTN))
if 'SLCTN
QUIT
Begin DoDot:2
+7 ;check for messed up index and take appropriate action
+8 SET NODE=$GET(^IBE(357.3,SLCTN,0))
+9 IF ($PIECE(NODE,"^",3)'=IBLIST)!($PIECE(NODE,"^",4)'=IBGRP)
Begin DoDot:3
+10 KILL ^IBE(357.3,"APO",IBLIST,IBGRP,ODR,SLCTN)
+11 IF $PIECE(NODE,"^",3)'=IBLIST
IF $PIECE(NODE,"^",4)=IBGRP
Begin DoDot:4
+12 KILL DIK,DA
SET DIK="^IBE(357.3,"
SET DA=SLCTN
DO ^DIK
KILL DIK,DA
End DoDot:4
QUIT
+13 IF $PIECE(NODE,"^",3)=IBLIST
IF $PIECE($GET(^IBE(357.4,+IBGRP,0)),"^",3)'=IBLIST
Begin DoDot:4
+14 KILL DIK,DA
SET DIK="^IBE(357.3,"
SET DA=SLCTN
DO ^DIK
KILL DIK,DA
End DoDot:4
QUIT
+15 KILL DIK,DA
SET DIK="^IBE(357.3,"
SET DA=SLCTN
DO IX^DIK
KILL DIK,DA
End DoDot:3
QUIT
+16 ;
+17 SET VALMCNT=VALMCNT+1
+18 SET @VALMAR@(VALMCNT,0)=$$DISPLAY(SLCTN,VALMCNT)
SET @VALMAR@("IDX",VALMCNT,VALMCNT)=SLCTN
+19 ;set video for ID column
DO FLDCTRL^VALM10(VALMCNT,"ID")
End DoDot:2
End DoDot:1
+20 ;User deleted all selections. Update history files during save.
IF ^TMP("IBDF DELETE SELECTION OPTION",$JOB)=1
IF '$ORDER(^IBE(357.3,"APO",IBLIST,IBGRP,""))
Begin DoDot:1
+21 SET ^TMP("IBDF DELETED ALL SELECTIONS",$JOB)=1
End DoDot:1
+22 QUIT
LMGRPHDR ;header for the screen
+1 SET VALMHDR(1)="SELECTIONS CURRENTLY DEFINED FOR '"_$$GRPNAME_"' PRINT GROUP"
+2 QUIT
+3 ;
GRPNAME() ;the name of the selection group
+1 QUIT $PIECE($GET(^IBE(357.4,IBGRP,0)),"^",1)
+2 ;
DISPLAY(SLCTN,COUNT) ;returns a line to display to the list containing a selection - SLCTN is a ptr to the selection, COUNT is the number of the selection on the list
+1 NEW SC,SCDA,VAL,RET,W,NODE,ORDER
+2 ;W - an array containing the widths of the subcolumns that contain text
+3 SET VAL=""
+4 SET RET=$$PADRIGHT^IBDFU(COUNT,4)
+5 SET NODE=$GET(^IBE(357.3,SLCTN,0))
+6 SET ORDER=$PIECE(NODE,"^",5)
SET RET=RET_$JUSTIFY(ORDER,6,2)
+7 IF $PIECE(NODE,"^",2)
SET RET=RET_$SELECT($PIECE(NODE,"^",7):" SH",1:" PH")_"| "_$PIECE(NODE,"^",6)
+8 IF '$PIECE(NODE,"^",2)
SET RET=RET_" "
SET SC=""
FOR SC=1:1:8
SET SCDA=$ORDER(^IBE(357.3,SLCTN,1,"B",SC,""))
Begin DoDot:1
+9 IF $GET(IBLIST("SCTYPE",SC))=1
SET W(SC)=IBLIST("SCW",SC)*(1+IBLIST("BTWN"))
+10 if $GET(W(SC))
SET VAL=$$PADRIGHT^IBDFU($SELECT(SCDA:$PIECE($GET(^IBE(357.3,SLCTN,1,SCDA,0)),"^",2),1:""),W(SC))
+11 if VAL'=""
SET RET=RET_" | "_VAL
+12 SET VAL=""
End DoDot:1
+13 IF $DATA(^IBE(357.3,SLCTN,2))
SET RET=RET_" "
SET SC=""
FOR SC=1:1:2
SET SCDA=$PIECE(^IBE(357.3,SLCTN,2),"^",SC)
if SC=2
SET SCDA=$SELECT($DATA(^LEX)>1:$PIECE($GET(^LEX(757.01,+SCDA,0)),"^"),1:$PIECE($GET(^GMP(757.01,+SCDA,0)),"^"))
Begin DoDot:1
+14 SET W(SC)=25
+15 SET VAL=$$PADRIGHT^IBDFU($SELECT(SCDA]"":SCDA,1:""),W(SC))
+16 if VAL'=""
SET RET=RET_" | "_VAL
+17 SET VAL=""
End DoDot:1
+18 QUIT RET
ADDSLCTN ;allows the user to add a selection to the selection group
+1 NEW QUIT,SUB
+2 ;
+3 SET VALMBCK="R"
+4 DO FULL^VALM1
+5 IF IBRTN("ACTION")'=3
DO NOGOOD
GOTO ADDEXIT
+6 SET ^TMP("IBDF ADDSLCTN",$JOB)=1
+7 KILL @IBRTN("DATA_LOCATION")
+8 SET QUIT=0
FOR
Begin DoDot:1
+9 IF '$$DORTN^IBDFU1B(.IBRTN)
SET QUIT=1
DO NOGOOD
QUIT
+10 IF '$DATA(@IBRTN("DATA_LOCATION"))
SET QUIT=1
QUIT
+11 ;edits and adds the selection
DO ADDREC(.QUIT)
+12 KILL @IBRTN("DATA_LOCATION")
End DoDot:1
if QUIT
QUIT
WRITE !!!,"Now for another SELECTION LIST entry!"
ADDEXIT ;
+1 DO IDXSLCTN
+2 QUIT
+3 ;IBDEXCOD - the external code that we are adding to the group (optional)
ADDREC(QUIT,ORDER,SLCTN,IBDEXCOD,IBDALL) ;allows the user to number the selection, edit the editable subcolumns, then adds the record - sets QUIT=1 if user quits
+1 NEW SUB,COUNT,NODE,VAL,DLAYGO,QTY,DTOUT,DUOUT,DIRUT
+2 IF $PIECE($GET(^IBE(357.6,$PIECE($GET(^IBE(357.2,+IBLIST,0)),"^",11),16)),"^",8)
SET DIR(0)="NO"
SET DIR("A")="Quantity"
SET DIR("B")=1
SET DIR("?")="Enter the number of occurrences"
DO ^DIR
KILL DIR
if $DATA(DTOUT)!$DATA(DUOUT)
SET QUIT=1
if QUIT
QUIT
SET QTY=$GET(Y)
+3 IF '$GET(ORDER)
Begin DoDot:1
+4 KILL DIR
SET DIR(0)="357.3,.05"
SET DIR("B")=$$NEXT^IBDF4A(IBLIST,IBGRP)
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET QUIT=1
QUIT
+5 SET ORDER=+Y
End DoDot:1
if QUIT
QUIT
+6 SET VAL=$GET(@IBRTN("DATA_LOCATION"))
+7 if QUIT
QUIT
+8 ;we have all the data needed to add the selection - so add it
+9 SET NODE=$SELECT($PIECE(VAL,"^")'="":$PIECE(VAL,"^"),1:ORDER)_"^^"_IBLIST_"^"_IBGRP_"^"_ORDER_$SELECT($GET(QTY):"^^^^"_QTY,1:"")
+10 KILL DIC,DD,DO,DINUM
SET DIC="^IBE(357.3,"
SET X=$PIECE(NODE,"^",1)
SET DIC(0)="FL"
SET DLAYGO=357.3
+11 DO FILE^DICN
KILL DIC,DIE,DA
+12 SET SLCTN=$SELECT(+Y<0:"",1:+Y)
+13 IF 'SLCTN
WRITE !,"Unable to create a new selection record!"
DO PAUSE^VALM1
SET QUIT=1
QUIT
+14 SET ^IBE(357.3,SLCTN,0)=NODE
+15 ;--- move codes and add modifiers
+16 DO CODES^IBDF4A(.QUIT)
+17 if QUIT
QUIT
+18 DO ADD^IBDF4C
+19 ;---move the subcolumn set up
+20 FOR SUB=1:1:8
Begin DoDot:1
+21 IF $GET(IBLIST("SCTYPE",SUB))=1
IF IBLIST("SCPIECE",SUB)
IF IBLIST("SCW",SUB)
Begin DoDot:2
+22 SET NODE=$$DATANODE^IBDFU1B(IBRTN,IBLIST("SCPIECE",SUB))
+23 IF NODE]""
SET VAL(SUB)=$PIECE($GET(@IBRTN("DATA_LOCATION")@(NODE)),"^",IBLIST("SCPIECE",SUB))
+24 IF '$TEST
SET VAL(SUB)=$PIECE(VAL,"^",IBLIST("SCPIECE",SUB))
+25 if ('IBLIST("SCEDITABLE",SUB))!((IBRTN("WIDTH",1))&(IBLIST("SCPIECE",SUB)=1))
QUIT
+26 WRITE !!,"Subcolumn Header: "_IBLIST("SCHDR",SUB)
KILL DIR
SET DIR(0)="FO^0:"_(IBLIST("SCW",SUB)*(1+IBLIST("BTWN")))
SET DIR("A")="Edit Subcolumn "_SUB
SET DIR("B")=VAL(SUB)_$SELECT($GET(QTY)>1:" x "_QTY,1:"")
+27 IF $PIECE($GET(^IBE(357.3,SLCTN,3,0)),"^",4)>0
Begin DoDot:3
+28 if DIR("B")'["w/ mod"
SET DIR("B")=DIR("B")_"w/ mod"
End DoDot:3
+29 DO ^DIR
KILL DIR
if $DATA(DTOUT)!($DATA(DUOUT))
SET QUIT=1
if QUIT
QUIT
SET VAL(SUB)=Y
IF IBLIST("SCPIECE",SUB)=1
IF X=""
SET QUIT=1
QUIT
End DoDot:2
End DoDot:1
if QUIT
QUIT
+30 if QUIT
QUIT
+31 ;
+32 ;add the subcolumn value multiple
+33 SET COUNT=0
FOR SUB=1:1:8
IF $GET(VAL(SUB))'=""
SET COUNT=COUNT+1
SET ^IBE(357.3,SLCTN,1,COUNT,0)=SUB_"^"_VAL(SUB)
+34 SET ^IBE(357.3,SLCTN,1,0)="^357.31IA^"_COUNT_"^"_COUNT
+35 KILL DA
SET DA=SLCTN
SET DIK="^IBE(357.3,"
DO IX^DIK
KILL DIK,DA
+36 DO NARR(.QUIT)
+37 if QUIT
QUIT
+38 DO TERM(.QUIT,$GET(IBDEXCOD))
+39 IF $GET(IBDRPCAL)
if $GET(IBDAI)="DG SELECT ICD-10 DIAGNOSIS CODES"
SET IBDX=$$CSUPD357^IBDUTICD(IBFORM,30,"",$$NOW^XLFDT(),DUZ)
DO ADDALREC(IBSEL)
+40 QUIT
+41 ;
NARR(IBDQUIT) ; -- edit provider narrative, but only for selections where the
+1 ; interface allows editing
+2 NEW DIE,DA,DR,Y
+3 IF $PIECE($GET(^IBE(357.6,+$PIECE($GET(^IBE(357.2,+IBLIST,0)),U,11),0)),U,17)
Begin DoDot:1
+4 SET DIE="^IBE(357.3,"
SET DA=SLCTN
SET DR=2.01
DO ^DIE
KILL DIE,DA,DR
End DoDot:1
+5 IF $DATA(Y)
SET IBDQUIT=1
+6 QUIT
+7 ;IBDCODEX - the external code that we are adding to the group (optional)
TERM(IBDQUIT,IBDCODEX) ; -- map selection to clinical lexicon, but only for selections where
+1 ; the package interface allows editing
+2 ;newed DIC to prevent bug in Lexicon
+3 NEW DIE,DA,DR,GMPTUN,GMPTSUB,GMPTSHOW,XTLKGLB,XTLKHLP,XTLKKSCH,XTLKSAY,IBDLEX,DIC,IBDDT
+4 NEW LEXQ,LEXVDT,Y,IBLEXNS,IBDLEXSS,IBD1STDT,IBDIMPDT
+5 ;
+6 SET IBLEXNS="GMPL"
SET IBDLEXSS="PL1"
+7 ;if this is ICD package interface then if it is ICD-10 then used "10D" if anything else (ICD9 at the moment) - use "ICD"
+8 IF $GET(IBRTN("NAME"))["ICD"
SET (IBLEXNS,IBDLEXSS)=$SELECT($GET(IBRTN("NAME"))["ICD-10":"10D",1:"ICD")
+9 ;
+10 ;keep using "" for ICD-9
SET IBDDT=""
+11 ;for ICD-10 codes:
+12 ;if IBDCODEX is not provided then use ICD-10 implementation date if it is prior to the ICD-10 implementation date
+13 ; and default if it is on and after
+14 ;if IBDCODEX is defined we rely on the selection logic (see FILTER^IBDUTICD). To pass CONFIG^LEXSET we
+15 ; use the latest ACTIVE status date of the code
+16 IF $GET(IBRTN("NAME"))["ICD-10"
Begin DoDot:1
+17 ; get the ICD-10 activation date
+18 SET IBDIMPDT=$$IMPDATE^IBDUTICD("10D")
+19 ;if code value is NOT defined/not available then
+20 ; set the date to ICD-10 activation if the user adds the code prior to ICD-10 system activation
+21 ; and to default "" if in and after ICD-10 activation and quit
+22 IF $GET(IBDCODEX)=""
SET IBDDT=$SELECT(DT<IBDIMPDT:IBDIMPDT,1:"")
QUIT
+23 ;if code value is available then get the date of the last ACTIVE status and use it for CONFIG^LEXSET
+24 SET IBDDT=$$LSTACTST^IBDUTICD(IBDCODEX)
+25 ;if not found for some reason then follow the logic "when the code is NOT available" above
+26 IF IBDDT=0
SET IBDDT=$SELECT(DT<IBDIMPDT:IBDIMPDT,1:"")
End DoDot:1
+27 IF $PIECE($GET(^IBE(357.6,+$PIECE($GET(^IBE(357.2,+IBLIST,0)),U,11),0)),U,18)
Begin DoDot:1
+28 IF $DATA(^LEX)>1
SET X="LEXSET"
XECUTE ^%ZOSF("TEST")
IF $TEST
DO CONFIG^LEXSET(IBLEXNS,IBDLEXSS,IBDDT)
SET IBDLEX=1
+29 IF '$DATA(IBDLEX)
SET X="GMPTSET"
XECUTE ^%ZOSF("TEST")
IF $TEST
DO CONFIG^GMPTSET(IBLEXNS,IBDLEXSS,IBDDT)
SET IBDLEX=1
+30 ;D CONFIG^GMPTSET("ICD","ICD") (this is an alternate filter)
+31 if '$DATA(IBDLEX)
QUIT
+32 SET DIE="^IBE(357.3,"
SET DA=SLCTN
SET DR="2.02//"_$PIECE($GET(^IBE(357.3,DA,0)),"^")
DO ^DIE
End DoDot:1
+33 KILL DIC
+34 IF $DATA(Y)
SET IBDQUIT=1
+35 QUIT
+36 ;
CODES ; -- allow selection of a second code to pass through for this entry
+1 ; -- only as if pi allows input of more than one code
+2 ;N PI S PI=+$P($G(^IBE(357.2,+IBLIST,0)),U,11)
+3 ;Q:'$P($G(^IBE(357.6,PI,16)),U,9)
+4 ;N IBI,QUIT,IBVAL S QUIT=0
+5 ;F IBI=1,2 D Q:QUIT
+6 ;.W !,"****Select a ",$S(IBI=1:"second",1:"third")," code to pass along with original."
+7 ;.I '$$DORTN^IBDFU1B(.IBRTN) S QUIT=1 Q
+8 ;.I +Y'>0 S QUIT=1 Q
+9 ;.X $G(^IBE(357.6,PI,9)) S IBVAL=X
+10 ;.S DIE="^IBE(357.3,",DA=SLCTN,DR=$S(IBI=1:"2.03",1:"2.04")_"////^S X=IBVAL" D ^DIE K DIE,DA,DR
+11 ;Q
+12 ;
NOGOOD ;
+1 WRITE !,"The package interface routine for selection is not properly defined"
DO PAUSE^VALM1
+2 QUIT
+3 ;
SEQUENCE ;allows the user to resequence all of the selections on the list
+1 ;
+2 NEW SUBCOL,CNT,P,SORT,GROUP,NODE,VALUE,ITEM,IEN,HDR,DTOUT,DUOUT,DIRUT,SORT1
+3 SET VALMBCK="R"
+4 DO FULL^VALM1
+5 ;
+6 ;sort by which subcolumn?
+7 KILL DIR
SET DIR("A")="Which subcolumn do you want to sort by?"
SET DIR("?")=" "
+8 SET SUBCOL=0
FOR
SET SUBCOL=$ORDER(IBLIST("SCTYPE",SUBCOL))
if 'SUBCOL
QUIT
IF IBLIST("SCTYPE",SUBCOL)=1
SET SUBCOL(SUBCOL)=""
+9 SET (CNT,SUBCOL)=0
SET DIR(0)="SOX^"
+10 FOR CNT=1:1
SET SUBCOL=$ORDER(SUBCOL(SUBCOL))
if 'SUBCOL
QUIT
Begin DoDot:1
+11 SET P=IBLIST("SCPIECE",SUBCOL)
SET P=$SELECT(P=1:1,P=2:3,P=3:5,P=4:7,P=5:9,P=6:11,P=7:13,1:0)
SET HDR=$PIECE($GET(^IBE(357.6,+IBLIST("RTN"),2)),"^",P)
SET DIR("?",CNT)=SUBCOL_" = "_HDR
+12 SET HDR=$SELECT($GET(IBLIST("SCHDR",SUBCOL))="":HDR,1:IBLIST("SCHDR",SUBCOL))
+13 SET DIR(0)=DIR(0)_SUBCOL_":"_HDR_";"
End DoDot:1
+14 DO ^DIR
+15 if $DATA(DIRUT)!(Y=-1)
QUIT
+16 KILL SUBCOL
SET SUBCOL=+Y
+17 ;
+18 ;sort alphabetically or numerically?
+19 KILL DIR
+20 SET DIR("A")="How should the list be sorted?"
SET DIR(0)="SO^1:ALPHABETICALLY;2:NUMERICALLY;"
SET DIR("B")="ALPHABETICALLY"
+21 DO ^DIR
+22 if $DATA(DIRUT)!(Y=-1)
QUIT
+23 SET SORT=Y
+24 ; -- Resequence by group or group and placeholders
+25 KILL DIR
+26 SET DIR("A")="Resequence by Group or Group and Place Holders?"
SET DIR(0)="SO^1:GROUP/PLACE HOLDERS;2:GROUP;"
SET DIR("B")="GROUP/PLACE HOLDERS"
+27 DO ^DIR
+28 if $DATA(DIRUT)!(Y=-1)
QUIT
+29 SET SORT1=Y
+30 ;
+31 ;sort
+32 IF SORT1=2
DO EN^IBDF4A
QUIT
+33 NEW CNTR,GROUP1,IBGROUP,IBORDER
+34 KILL ^TMP("IBDF",$JOB)
+35 SET (GROUP,GROUP1,CNTR,IBGROUP)=0
+36 ; -- Resequence only specific groups in block.
+37 IF $DATA(IBGRUP)
FOR
SET IBGROUP=$ORDER(IBGRUP(IBGROUP))
if 'IBGROUP
QUIT
DO RESEQ
+38 IF $DATA(IBGRUP)
DO ORDER
QUIT
+39 ; -- Resequence all groups of the block.
+40 IF '$DATA(IBGRUP)
FOR
SET IBGROUP=$ORDER(^IBE(357.3,"APO",IBLIST,IBGROUP))
if 'IBGROUP
QUIT
DO RESEQ
+41 IF '$DATA(IBGRUP)
DO ORDER
QUIT
+42 QUIT
RESEQ SET IBORDER=0
FOR
SET IBORDER=$ORDER(^IBE(357.3,"APO",IBLIST,IBGROUP,IBORDER))
if 'IBORDER
QUIT
SET ITEM=0
FOR
SET ITEM=$ORDER(^IBE(357.3,"APO",IBLIST,IBGROUP,IBORDER,ITEM))
if 'ITEM
QUIT
Begin DoDot:1
+1 SET NODE=$GET(^IBE(357.3,ITEM,0))
+2 IF ($PIECE(NODE,"^",3)'=IBLIST)
QUIT
+3 SET GROUP1=GROUP
SET GROUP=+$PIECE(NODE,"^",4)
+4 if $PIECE($GET(^IBE(357.4,GROUP,0)),"^",3)'=IBLIST
QUIT
+5 IF $PIECE(NODE,"^",2)=1
Begin DoDot:2
+6 SET CNTR=CNTR+1
+7 SET VALUE=$SELECT(SORT=1:" ",1:+$PIECE(NODE,"^",1))
+8 SET ^TMP("IBDF",$JOB,"RESEQUENCE LIST",GROUP,CNTR,VALUE,ITEM)=""
End DoDot:2
QUIT
+9 SET IEN=$ORDER(^IBE(357.3,ITEM,1,"B",SUBCOL,0))
if 'IEN
QUIT
+10 SET VALUE=$PIECE($GET(^IBE(357.3,ITEM,1,IEN,0)),"^",2)
+11 SET VALUE=$SELECT(SORT=1:VALUE=" "_VALUE,1:+$PIECE(NODE,"^",1))
+12 IF GROUP'=GROUP1
SET CNTR=CNTR+1
+13 SET ^TMP("IBDF",$JOB,"RESEQUENCE LIST",GROUP,CNTR,$EXTRACT(VALUE,1,40),ITEM)=""
End DoDot:1
+14 ;set the order
ORDER SET GROUP=0
SET CNTR=0
+1 FOR
SET GROUP=$ORDER(^TMP("IBDF",$JOB,"RESEQUENCE LIST",GROUP))
if 'GROUP
QUIT
Begin DoDot:1
+2 SET VALUE=""
SET CNT=0
+3 FOR
SET CNTR=$ORDER(^TMP("IBDF",$JOB,"RESEQUENCE LIST",GROUP,CNTR))
if 'CNTR
QUIT
FOR
SET VALUE=$ORDER(^TMP("IBDF",$JOB,"RESEQUENCE LIST",GROUP,CNTR,VALUE))
if VALUE=""
QUIT
Begin DoDot:2
+4 SET ITEM=0
FOR
SET ITEM=$ORDER(^TMP("IBDF",$JOB,"RESEQUENCE LIST",GROUP,CNTR,VALUE,ITEM))
if 'ITEM
QUIT
Begin DoDot:3
+5 SET CNT=CNT+1
+6 KILL DIE,DA,DR
SET DIE="^IBE(357.3,"
SET DR=".05///"_CNT
SET DA=ITEM
DO ^DIE
KILL DIE,DA,DR
End DoDot:3
End DoDot:2
End DoDot:1
+7 ;
+8 KILL Y,X,DIR,^TMP("IBDF",$JOB,"RESEQUENCE LIST")
+9 DO IDXGRP^IBDF3
+10 QUIT
ADDALREC(IBSEL) ;updates all forms with the same code
+1 NEW IBDCD,IBDY,IBDNODE,IBDOLD,IBDERR,IBDN,IBDSUB,IBDSUB1,IBDN1,IBDATA,IBDNEW,IBDCODE,IBDFRN,IBDBLK,IBDFRM1,IBDFORM,IBDDPC,IBDDUP,IBDTMP1,IBDCL,IBDYS,IBDSBI,IBDSELN,IBDSNEW,DA,DIK
+2 NEW IBDFSEL,IBDATA1,IBBLK,IBDANT
+3 SET IBDANT=1
+4 KILL ^TMP("IBDANT",$JOB)
SET ^TMP("IBDANT",$JOB,IBDANT)=^IBE(357.3,SLCTN,0)
+5 SET IBDCD=$PIECE(IBDFSLC,U)
SET IBDY=0
FOR
SET IBDY=$ORDER(^XTMP("CPTIDX",IBDY))
if 'IBDY
QUIT
IF $PIECE(^XTMP("CPTIDX",IBDY),U,2)=IBDCD
Begin DoDot:1
+6 SET IBDDPC=0
SET IBDDUP=0
FOR
SET IBDDPC=$ORDER(IBDSEL1(IBDDPC))
if 'IBDDPC
QUIT
Begin DoDot:2
+7 IF $PIECE(^XTMP("CPTIDX",IBDY),U,2,6)=$PIECE(^XTMP("CPTIDX",IBDDPC),U,2,6)
SET IBDDUP=1
SET IBDTMP1=$PIECE($GET(^XTMP("CPTIDX",IBDY)),"^")
SET DA=$PIECE(^XTMP("CPTIDX",IBDDPC),U,4)
SET DIK="^IBE(357.3,"
DO ^DIK
KILL DIK
End DoDot:2
+8 IF IBDDUP
if ^XTMP("IBDCPT",IBDTMP1,0)'=" "
SET ^XTMP("IBDCPT",IBDTMP1,0)=$PIECE(^XTMP("IBDCPT",IBDTMP1,0),")")_") *******Replaced*******"
Begin DoDot:2
+9 SET IBDFSEL=$PIECE(^XTMP("CPTIDX",IBDY),U,4)
+10 SET ^XTMP("CPTIDX",IBDY)="*Replaced*"
End DoDot:2
QUIT
+11 SET IBDFORM=$PIECE($GET(^XTMP("CPTIDX",IBDY)),"^",5)
+12 SET IBDTMP1=$PIECE($GET(^XTMP("CPTIDX",IBDY)),"^")
+13 SET IBBLK=$PIECE($GET(^XTMP("CPTIDX",IBDY)),"^",6)
+14 SET IBDFSEL=$PIECE(^XTMP("CPTIDX",IBDY),U,4)
SET IBDNODE=$GET(^IBE(357.3,IBDFSEL,0))
IF IBDNODE=""
Begin DoDot:2
+15 if ^XTMP("IBDCPT",IBDTMP1,0)'=" "
SET ^XTMP("IBDCPT",IBDTMP1,0)=$PIECE(^XTMP("IBDCPT",IBDTMP1,0),")")_") *******Replaced*******"
SET ^XTMP("CPTIDX",IBDY)="*Replaced*"
End DoDot:2
QUIT
+16 KILL DIC,DD,DO,DINUM
SET DIC="^IBE(357.3,"
SET X=$PIECE(^IBE(357.3,IBSEL,0),"^",1)
SET DIC(0)="FL"
SET DLAYGO=357.3
DO FILE^DICN
SET IBDNEW=+Y
KILL DIC,DIE,DA
+17 SET IBDYS=IBDFSEL_","
DO GETS^DIQ(357.3,IBDYS,"**","NI","IBDOLD","IBDERR")
+18 SET IBDN=.01
SET DIE="^IBE(357.3,"
SET DA=IBDNEW
FOR
SET IBDN=$ORDER(IBDOLD(357.3,IBDYS,IBDN))
if 'IBDN
QUIT
Begin DoDot:2
+19 SET IBDATA=IBDOLD(357.3,IBDYS,IBDN,"I")
IF IBDATA'=""
IF IBDN'=.03
IF IBDN'=.04
IF IBDN'=2.02
IF IBDN'=4.02
SET DR=IBDN_"///"_IBDATA
DO ^DIE
End DoDot:2
+20 SET IBDATA=$GET(IBDOLD(357.3,IBDYS,.03,"I"))
IF IBDATA'=""
SET DR=".03////"_IBDATA
DO ^DIE
+21 SET IBDATA=$GET(IBDOLD(357.3,IBDYS,.04,"I"))
IF IBDATA'=""
SET DR=".04////"_IBDATA
DO ^DIE
+22 SET IBDATA=$GET(IBDOLD(357.3,IBDYS,2.02,"I"))
IF IBDATA'=""
SET DR="2.02////"_IBDATA
DO ^DIE
+23 SET IBDATA=$GET(IBDOLD(357.3,IBDYS,4.02,"I"))
IF IBDATA'=""
SET DR="4.02////"_IBDATA
DO ^DIE
+24 SET IBDSELN=IBSEL_","
DO GETS^DIQ(357.3,IBDSELN,"**","N","IBDCODE","IBDERR")
+25 IF $DATA(IBDCODE(357.31))
SET IBDSUB=""
FOR
SET IBDSUB=$ORDER(IBDCODE(357.31,IBDSUB))
if IBDSUB=""
QUIT
SET IBDSBI=IBDCODE(357.31,IBDSUB,.01)
SET DIC="^IBE(357.3,"_IBDNEW_",1,"
SET X=IBDSBI
SET DA(1)=IBDNEW
SET DA=X
SET DIC(0)="FL"
SET DLAYGO=357.31
DO FILE^DICN
SET IBDSNEW=+Y
Begin DoDot:2
+26 SET IBDN1=.01
SET DIE="^IBE(357.3,"_DA(1)_",1,"
SET DA(1)=IBDNEW
SET DA=IBDSNEW
SET IBDSUB1=.01
FOR
SET IBDSUB1=$ORDER(IBDCODE(357.31,IBDSUB,IBDSUB1))
if IBDSUB1=""
QUIT
SET IBDATA1=IBDCODE(357.31,IBDSUB,IBDSUB1)
IF IBDATA1'=""
SET DR=IBDSUB1_"///^S X=IBDATA1"
DO ^DIE
End DoDot:2
+27 IF $DATA(IBDCODE(357.33))
SET IBDSUB=""
FOR
SET IBDSUB=$ORDER(IBDCODE(357.33,IBDSUB))
if IBDSUB=""
QUIT
SET IBDSBI=IBDCODE(357.33,IBDSUB,.01)
SET DIC="^IBE(357.3,"_IBDNEW_",3,"
SET X=IBDSBI
SET DA(1)=IBDNEW
SET DA=X
SET DIC(0)="FL"
SET DLAYGO=357.33
DO FILE^DICN
SET IBDSNEW=+Y
Begin DoDot:2
+28 SET IBDN1=.01
SET DIE="^IBE(357.3,"_DA(1)_",3,"
SET DA(1)=IBDNEW
SET DA=IBDSNEW
SET IBDSUB1=.01
FOR
SET IBDSUB1=$ORDER(IBDCODE(357.33,IBDSUB,IBDSUB1))
if IBDSUB1=""
QUIT
SET IBDATA1=IBDCODE(357.31,IBDSUB,IBDSUB1)
IF IBDATA1'=""
SET DR=IBDSUB1_"///^S X=IBDATA1"
DO ^DIE
End DoDot:2
+29 SET DA=IBDFSEL
SET DIK="^IBE(357.3,"
DO ^DIK
KILL DIK
+30 SET IBDANT=IBDANT+1
SET ^TMP("IBDANT",$JOB,IBDANT)=^IBE(357.3,IBDNEW,0)
+31 if ^XTMP("IBDCPT",IBDTMP1,0)'=" "
SET ^XTMP("IBDCPT",IBDTMP1,0)=$PIECE(^XTMP("IBDCPT",IBDTMP1,0),")")_") *******Replaced*******"
SET ^XTMP("CPTIDX",IBDY)="*Replaced*"
End DoDot:1
+32 QUIT
