- 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 Mar 13, 2025@21:56:44 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
