IBDF9A3 ;ALB/CJM - ENCOUNTER FORM - (create,edit,delete selection list - continued) ;NOV 5,1994
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
GETSC(ARY,LIST) ;makes a list of subcolumns having text
N SC,NODE
S SC=0 F S SC=$O(^IBE(357.2,LIST,2,SC)) Q:'SC S NODE=$G(^IBE(357.2,LIST,2,SC,0)) I $P(NODE,"^",4)=1 S ARY(+NODE)=$P(NODE,"^",5)
Q
DELSC(LIST,SC) ;delete subcolumn=SC for selections on LIST
N SLCTN,SCIEN
K DA,DIK
S SLCTN=0 F S SLCTN=$O(^IBE(357.3,"C",LIST,SLCTN)) Q:'SLCTN S SCIEN=0 F S SCIEN=$O(^IBE(357.3,SLCTN,1,"B",SC,SCIEN)) Q:'SCIEN D
.I $P($G(^IBE(357.3,SLCTN,1,SCIEN,0)),"^")=SC D
..S DIK="^IBE(357.3,"_SLCTN_",1,",DA(1)=SLCTN,DA=SCIEN D ^DIK
.E D
..K ^IBE(357.3,SLCTN,1,"B",SC,SCIEN)
..S DIK="^IBE(357.3,SLCTN,1,",DA(1)=SLCTN,DA=SCIEN D IX^DIK
K DIK,DA
Q
ADDSC(LIST,SC) ;ADD subcolumn=SC for selections on LIST if not already there, else set to blank
N SLCTN,SCIEN ;,IBNEWSC,IBFLG
;S IBNEWSC=IBSCNEW(SC)
;S IBTHERE=0
;F S IBTHERE=$O(IBSCOLD(IBTHERE)) Q:'IBTHERE D Q:$D(IBFLG)
;.;I IBNEWSC=IBTHERE S IBFLG=1 Q
;.;I IBNEWSC=3,IBTHERE=2 S IBFLG=1 Q
;I $D(IBFLG) D
;.;I IBTHERE=IBNEWSC W !!,"The new subcolum "_IBNEWSC_" contains the same
;.;I IBTHERE=IBNEWSC W !!,"The new subcolum "_IBNEWSC_" contains the samedata as the the new subcolumn.",!,"**New subcolumn deleted**"
;W "The new subcolum "_IBNEWSC_" contains the samedata as the the new subcolumn, but different subcolumn width. ** Change subcolumn width**",!,"**New subcolumn deleted**"
S SLCTN=0 F S SLCTN=$O(^IBE(357.3,"C",LIST,SLCTN)) Q:'SLCTN D
.;re-index the record, to insure it is good
.K DIK,DA S DIK="^IBE(357.3,",DA=SLCTN D IX^DIK
.S SCIEN=$O(^IBE(357.3,SLCTN,1,"B",SC,0))
.;
.;should be empty if it already exists
.I SCIEN S $P(^IBE(357.3,SLCTN,1,SCIEN,0),"^",2)="" Q
.;
.;it doesnt already exist, so create it
.K DA,DIC,DO,DINUM
.S DIC="^IBE(357.3,"_SLCTN_",1,",DA(1)=SLCTN,X=SC,DIC(0)="" D FILE^DICN
K DIC,DO,DA,DIK
Q
;
OTHER ;
N INPUT,NODE
S NODE=$G(^IBE(357.6,16,0))
S INPUT("NARRATIVE")=$P(NODE,"^"),INPUT("NARRATIVE","NAME")=$P(NODE,"^",2),INPUT("NARRATIVE","DATATYPE")=$P(NODE,"^",3),INPUT("CODE")=$P(NODE,"^",4),INPUT("CODE","NAME")=$P(NODE,"^",6),INPUT("CODE","DATATYPE")=$P(NODE,"^",7)
Q
SCLOOP ; -- Looping thru the subc setting up array(type of data)=subcolumn
S (IBSC3,IBSC4)=0
F S IBSC3=$O(^IBE(357.2,IBLIST,2,"B",IBSC3)) Q:'IBSC3 F S IBSC4=$O(^IBE(357.2,IBLIST,2,"B",IBSC3,IBSC4)) Q:'IBSC4 I $P($G(^IBE(357.2,IBLIST,2,IBSC4,0)),"^",5)]"" D
.S IBSCRAY($P($G(^IBE(357.2,IBLIST,2,IBSC4,0)),"^",5))=$P($G(^IBE(357.2,IBLIST,2,IBSC4,0)),"^",1)
Q
SCDEL ; -- Deletes the new subcolumn if there is already a column for that
; type of data.
N DA,DIK
I "^1^2^3^"'[X Q
I IBSC1(IBSC1)'="^",X'=$P(IBSC1(IBSC1),"^",2) S X=$P(IBSC1(IBSC1),"^",2) S $P(^IBE(357.2,D0,2,D1,0),"^",5)=X D MSG1 Q
Q:IBSC1(IBSC1)'="^"
;S DIK="^IBE(357.2,",DA=IBSC1
I "^1^2^3^"[X I $D(IBSCRAY(X)) D DIK Q
;I X=2 I $D(IBSCRAY(3)) D DIK Q
;I X=3 I $D(IBSCRAY(2)) D DIK Q
;K DA,DIK Q
Q
DIK ; -- KILL SUBCOLUMN GLOBAL
W !!,"*** SUBCOUMN "_IBSC1_" DELETED ***",!,"This data already exists in subcolumn "_IBSCRAY(X)_". Go in and edit its subcolumn number.",!!
S DIK="^IBE(357.2,"_D0_",2,",DA(1)=D0,DA=D1 D ^DIK
S IBDFFLG=1
;K DA,DIK Q
Q
MSG1 ;
W !!,"*** PREVENTING LOSS OF DATA - THIS FIELD CAN NOT BE EDITED ***",!,"You will need to add a new subcolumn to update this information",!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF9A3 3504 printed Apr 09, 2024@20:49 Page 2
IBDF9A3 ;ALB/CJM - ENCOUNTER FORM - (create,edit,delete selection list - continued) ;NOV 5,1994
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
GETSC(ARY,LIST) ;makes a list of subcolumns having text
+1 NEW SC,NODE
+2 SET SC=0
FOR
SET SC=$ORDER(^IBE(357.2,LIST,2,SC))
if 'SC
QUIT
SET NODE=$GET(^IBE(357.2,LIST,2,SC,0))
IF $PIECE(NODE,"^",4)=1
SET ARY(+NODE)=$PIECE(NODE,"^",5)
+3 QUIT
DELSC(LIST,SC) ;delete subcolumn=SC for selections on LIST
+1 NEW SLCTN,SCIEN
+2 KILL DA,DIK
+3 SET SLCTN=0
FOR
SET SLCTN=$ORDER(^IBE(357.3,"C",LIST,SLCTN))
if 'SLCTN
QUIT
SET SCIEN=0
FOR
SET SCIEN=$ORDER(^IBE(357.3,SLCTN,1,"B",SC,SCIEN))
if 'SCIEN
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^IBE(357.3,SLCTN,1,SCIEN,0)),"^")=SC
Begin DoDot:2
+5 SET DIK="^IBE(357.3,"_SLCTN_",1,"
SET DA(1)=SLCTN
SET DA=SCIEN
DO ^DIK
End DoDot:2
+6 IF '$TEST
Begin DoDot:2
+7 KILL ^IBE(357.3,SLCTN,1,"B",SC,SCIEN)
+8 SET DIK="^IBE(357.3,SLCTN,1,"
SET DA(1)=SLCTN
SET DA=SCIEN
DO IX^DIK
End DoDot:2
End DoDot:1
+9 KILL DIK,DA
+10 QUIT
ADDSC(LIST,SC) ;ADD subcolumn=SC for selections on LIST if not already there, else set to blank
+1 ;,IBNEWSC,IBFLG
NEW SLCTN,SCIEN
+2 ;S IBNEWSC=IBSCNEW(SC)
+3 ;S IBTHERE=0
+4 ;F S IBTHERE=$O(IBSCOLD(IBTHERE)) Q:'IBTHERE D Q:$D(IBFLG)
+5 ;.;I IBNEWSC=IBTHERE S IBFLG=1 Q
+6 ;.;I IBNEWSC=3,IBTHERE=2 S IBFLG=1 Q
+7 ;I $D(IBFLG) D
+8 ;.;I IBTHERE=IBNEWSC W !!,"The new subcolum "_IBNEWSC_" contains the same
+9 ;.;I IBTHERE=IBNEWSC W !!,"The new subcolum "_IBNEWSC_" contains the samedata as the the new subcolumn.",!,"**New subcolumn deleted**"
+10 ;W "The new subcolum "_IBNEWSC_" contains the samedata as the the new subcolumn, but different subcolumn width. ** Change subcolumn width**",!,"**New subcolumn deleted**"
+11 SET SLCTN=0
FOR
SET SLCTN=$ORDER(^IBE(357.3,"C",LIST,SLCTN))
if 'SLCTN
QUIT
Begin DoDot:1
+12 ;re-index the record, to insure it is good
+13 KILL DIK,DA
SET DIK="^IBE(357.3,"
SET DA=SLCTN
DO IX^DIK
+14 SET SCIEN=$ORDER(^IBE(357.3,SLCTN,1,"B",SC,0))
+15 ;
+16 ;should be empty if it already exists
+17 IF SCIEN
SET $PIECE(^IBE(357.3,SLCTN,1,SCIEN,0),"^",2)=""
QUIT
+18 ;
+19 ;it doesnt already exist, so create it
+20 KILL DA,DIC,DO,DINUM
+21 SET DIC="^IBE(357.3,"_SLCTN_",1,"
SET DA(1)=SLCTN
SET X=SC
SET DIC(0)=""
DO FILE^DICN
End DoDot:1
+22 KILL DIC,DO,DA,DIK
+23 QUIT
+24 ;
OTHER ;
+1 NEW INPUT,NODE
+2 SET NODE=$GET(^IBE(357.6,16,0))
+3 SET INPUT("NARRATIVE")=$PIECE(NODE,"^")
SET INPUT("NARRATIVE","NAME")=$PIECE(NODE,"^",2)
SET INPUT("NARRATIVE","DATATYPE")=$PIECE(NODE,"^",3)
SET INPUT("CODE")=$PIECE(NODE,"^",4)
SET INPUT("CODE","NAME")=$PIECE(NODE,"^",6)
SET INPUT("CODE","DATATYPE")=$PIECE(NODE,"^",7)
+4 QUIT
SCLOOP ; -- Looping thru the subc setting up array(type of data)=subcolumn
+1 SET (IBSC3,IBSC4)=0
+2 FOR
SET IBSC3=$ORDER(^IBE(357.2,IBLIST,2,"B",IBSC3))
if 'IBSC3
QUIT
FOR
SET IBSC4=$ORDER(^IBE(357.2,IBLIST,2,"B",IBSC3,IBSC4))
if 'IBSC4
QUIT
IF $PIECE($GET(^IBE(357.2,IBLIST,2,IBSC4,0)),"^",5)]""
Begin DoDot:1
+3 SET IBSCRAY($PIECE($GET(^IBE(357.2,IBLIST,2,IBSC4,0)),"^",5))=$PIECE($GET(^IBE(357.2,IBLIST,2,IBSC4,0)),"^",1)
End DoDot:1
+4 QUIT
SCDEL ; -- Deletes the new subcolumn if there is already a column for that
+1 ; type of data.
+2 NEW DA,DIK
+3 IF "^1^2^3^"'[X
QUIT
+4 IF IBSC1(IBSC1)'="^"
IF X'=$PIECE(IBSC1(IBSC1),"^",2)
SET X=$PIECE(IBSC1(IBSC1),"^",2)
SET $PIECE(^IBE(357.2,D0,2,D1,0),"^",5)=X
DO MSG1
QUIT
+5 if IBSC1(IBSC1)'="^"
QUIT
+6 ;S DIK="^IBE(357.2,",DA=IBSC1
+7 IF "^1^2^3^"[X
IF $DATA(IBSCRAY(X))
DO DIK
QUIT
+8 ;I X=2 I $D(IBSCRAY(3)) D DIK Q
+9 ;I X=3 I $D(IBSCRAY(2)) D DIK Q
+10 ;K DA,DIK Q
+11 QUIT
DIK ; -- KILL SUBCOLUMN GLOBAL
+1 WRITE !!,"*** SUBCOUMN "_IBSC1_" DELETED ***",!,"This data already exists in subcolumn "_IBSCRAY(X)_". Go in and edit its subcolumn number.",!!
+2 SET DIK="^IBE(357.2,"_D0_",2,"
SET DA(1)=D0
SET DA=D1
DO ^DIK
+3 SET IBDFFLG=1
+4 ;K DA,DIK Q
+5 QUIT
MSG1 ;
+1 WRITE !!,"*** PREVENTING LOSS OF DATA - THIS FIELD CAN NOT BE EDITED ***",!,"You will need to add a new subcolumn to update this information",!!
+2 QUIT
